BARUP1 ; IHS/SD/LSL - 3P UPLOAD CONTINUED DEC 5,1996 ;
;;1.8;IHS ACCOUNTS RECEIVABLE;**1,19,21,24**;OCT 26, 2005;Build 69
;
; IHS/ASDS/LSL - 9/11/01 - Version 1.5 Patch 2 - Modified to
; accomodate Pharmacy POS. Passes RX through to Other Bill
; Identifier field.
;
; IHS/SD/LSL - 11/27/02 - V1.7 - QAA-1200-130051
; Modified to insert quit logic if error in creating a new
; transaction. Also inserted documentation.
;
; IHS/SD/LSL - 06/09/03 - V1.7 Patch 1
; If uploading bill (not created through 3P Claim Approval),
; create BILL NEW transaction with 3P Approval Date and populate
; Message and Text fields of transaction.
;
; IHS/SD/LSL - 08/21/03 - V1.7 Patch 2 - IM11348
; Allow for checking of existing manually entered bill. Avoid
; duplicate bills in AR.
;
; IHS/SD/LSL - 09/10/03 - V1.7 Patch 3 - IM11459
; Resolve creation of multiple bills in AR when print or reprint
; from 3P.
;
; IHS/SD/RTL - 04/28/05 - V1.8 Patch 1 - IM17271
; Dupilcate bills
;
; ************************
;
; Global changes for indirection global - ABMA to @BAR3PUP@
;
;** Upload from 3P BILL file to A/R BILL/IHS file
; ---- continuation from ^BARUP
;
;** This routine is intended to be called from the 3p billing module
; at the time an item is created in the 3P BILL file.
;
;** Calling this routine at the entry point TPB^BARUP(ABMA ARRAY)
; will create an entry in the A/R BILL/IHS file.
;
; *************************
; IHS/SD/SDR HEAT118656 belcourt JUNE 2013 - BAR*1.8*.24
; IHS/SD/SDR 10/10/13 HEAT135708 - BAR*1.8*.24
; *************************
Q
UPLOAD ; EP
; Create a new in A/R Bill File based on 3P data
I '$D(BAR3PUP) D S3PUP
D LK2 ; See if bill already exists for this parent in A/R
I +BARBLDA>0 D
. D UPDATE
. I BARXX,$G(^TMP("BAR",$J,"BARUPCHK",$J)) D Q ; Already uploaded
. . S BARACT=$$CMP^BARUPCHK(BARBLDA)
. . S ^TMP($J,"BARXX")=BARXX
. D BILLOAD
I +BARBLDA<1 D ADD ; Bill not found, try adding it
I +BARBLDA<1 D NOT ; Could not find/add bill in A/R
Q
; *************************
;
S3PUP ;set BAR3PUP variable
S BAR3PUP="^TMP($J,""ABMPASS"")"
Q
; *************************
;
LK2 ;
; Try to find the 3PB bill under this parent in A/R
N BARTMP
S BARBLDA=-1
S BARSNM=$P(@BAR3PUP@("BLNM"),"-",1)
S BARNNM=+BARSNM_" "
;F S BARNNM=$O(^BARBL(DUZ(2),"B",BARNNM)) Q:((+$P(BARNNM,"-")'=+BARSNM)!(BARBLDA>0)) D
F S BARNNM=$O(^BARBL(DUZ(2),"B",BARNNM)) Q:(($E(BARNNM,1,$L(+BARSNM))'=(+BARSNM))!(BARBLDA>0)) D ;IM17271
. I $P(BARNNM,"-")'=BARSNM Q
. S BARTMP=0
. F S BARTMP=$O(^BARBL(DUZ(2),"B",BARNNM,BARTMP)) Q:('+BARTMP!(BARBLDA>0)) D
. . Q:$P($G(^BARBL(DUZ(2),BARTMP,0)),U,17)'=@BAR3PUP@("BLDA") ;3P IEN (DA)
. . Q:$P($G(^BARBL(DUZ(2),BARTMP,1)),U)'=@BAR3PUP@("PTNM") ;PATIENT DFN
. . S BARBLDA=BARTMP
Q
; *************************
ADD ;
; Create entry in A/R Bill file
S DIC="^BARBL(DUZ(2),"
S DIC(0)="LX"
S X=@BAR3PUP@("BLNM")
S DLAYGO=90050
K DD,DO
D FILE^DICN
K DLAYGO
I +Y<1 Q
S BARBLDA=+Y
; Tell 3P where A/R put the bill
S ^TMP($J,"ABMPASS","ARLOC")=DUZ(2)_","_BARBLDA
D BILLOAD ;Add items from 3P to AR
D SETTX ; Create BILL NEW transaction
Q
; *************************
;
NOT ;
; Write message
Q:$D(ZTQUEUED)
U IO(0)
W !,@BAR3PUP@("BLNM"),?10,"BILL NOT FOUND NOR ADDED ???"
U IO
Q
; *************************
;
UPDATE ;EP
; Update .01 field of A/R Bill
K DR
S DIE="^BARBL(DUZ(2),"
S DA=BARBLDA
I @BAR3PUP@("BLNM")'=$P(^BARBL(DUZ(2),DA,0),U) D
. S DR=".01///"_@BAR3PUP@("BLNM")
.D ^DIE
S BARXX=$$GET1^DIQ(90050.01,BARBLDA,13) ;check if previously loaded
Q
; *************************
;
BILLOAD ;EP - called by barupchk
; add/reload item from 3P to A/R everytime
I '$D(BARXX) D
.I '$D(^TMP($J,"BARXX")) Q
.I $D(^TMP($J,"BARXX")) D
. . S BARXX=^TMP($J,"BARXX")
. . K ^TMP($J,"BARXX")
I '$D(BAR3PUP) D S3PUP
I $G(BARXX) D ITMRLOAD Q ; Previously loaded
D BILLOAD2 ; Add top level A/R Bill data
D SETITM
D SETCOLL ;IHS/SD/AR 1.8*19 07182010
Q
; *************************
;
ITMRLOAD ;
; Bill previously loaded into A/R, delete old items and create new ones
D DELITM ; Delete Items
D SETITM ; Create Items
; -------------------------------
;
; Update 3P IEN, 3P DUZ(2), and export date on A/R Bill
K DA,DIC,DIE,X,Y,DR
S DA=BARBLDA
S DIE="^BARBL(DUZ(2),"
I $L(@BAR3PUP@("BLDA")) D
. S DR="17////^S X=@BAR3PUP@(""BLDA"")"
. S DR=DR_";22////^S X=BARDUZ2"
. I $L(@BAR3PUP@("DTBILL")) S DR=DR_";19////^S X=@BAR3PUP@(""DTBILL"")"
. S DIE=$$DIC^XBDIQ1(90050.01)
. D ^DIE
; -------------------------------
;
; Write message
Q:$E(IOST)'="C"
Q:IOT'["TRM"
Q:$D(ZTQUEUED)
W !,@BAR3PUP@("BLNM")
W " Previously loaded .. deleting existing A/R Bill items",!
W !,@BAR3PUP@("BLNM")," Now adding 3P Bill items to A/R Bill",!
Q
; *************************
;
BILLOAD2 ;
; Populate top level A/R Bill data
S @BAR3PUP@("BLAMT")=@BAR3PUP@("BLAMT")*100+.5\1/100
;S @BAR3PUP@("CURTOT")=@BAR3PUP@("BLAMT")-$G(@BAR3PUP@("CREDIT")) ;IHS/SD/SDR HEAT118656 belcourt
S @BAR3PUP@("CURTOT")=@BAR3PUP@("BLAMT") ;IHS/SD/SDR HEAT118656 belcourt
Q:'$D(BARPAR)
S DIE="^BARBL(DUZ(2),"
S DA=BARBLDA
S DIDEL=90050
; -------------------------------
DR01 ;
; Populate 1st half zero node
S DR=""
S DR=DR_"3////^S X=BARACEIN"
S DR=DR_";4////^S X=BARBLTYP"
S DR=DR_";8////^S X=BARPAR"
S DR=DR_";10////^S X=BARSERV"
S DR=DR_";11////3PU"
S DR=DR_";13////^S X=$G(@BAR3PUP@(""BLAMT""))"
S DR=DR_";15////^S X=$G(@BAR3PUP@(""CURTOT""))"
S DR=DR_";1001////^S X=$G(@BAR3PUP@(""LICN""))" ;IHS/SD/TPF BAR*1.8*21 5010 SPECS PAGE 16
D ^DIE
; -------------------------------
DR02 ;
; Popolate 2nd half zero node
S DR=""
S DR=DR_"16////^S X=BARSTAT"
S DR=DR_";17///^S X=$G(@BAR3PUP@(""BLDA""))"
S DR=DR_";18////^S X=@BAR3PUP@(""DTAP"")"
;S DR=DR_";18////^S X=@BAR3PUP@(""DTAP"");Q"
S DR=DR_";19////^S X=@BAR3PUP@(""DTBILL"")"
S DR=DR_";20///^S X=@BAR3PUP@(""CREDIT"")"
S DR=DR_";22////^S X=BARDUZ2"
D ^DIE
; -------------------------------
DR11 ;
; Populate 1st half one node
S DR=""
S DR=DR_"101////^S X=$G(@BAR3PUP@(""PTNM""))"
S DR=DR_";102////^S X=$G(@BAR3PUP@(""DOSB""))"
S DR=DR_";103////^S X=$G(@BAR3PUP@(""DOSE""))"
S DR=DR_";105////^S X=BARSSN"
S DR=DR_";106////^S X=BARPTYP"
S DR=DR_";107////^S X=BARHRN"
D ^DIE
; -------------------------------
DR12 ;
; Populate 2nd half one node
S DR=""
S DR=DR_"108////^S X=BARSAT"
S DR=DR_";112////^S X=$G(@BAR3PUP@(""CLNC""))"
S DR=DR_";113////^S X=BARPRV"
S DR=DR_";114////^S X=$G(@BAR3PUP@(""VSTP""))"
S DR=DR_";115////^S X=BARPBEN"
D ^DIE
; -------------------------------
DR278 ;
; Popolate two, seven, and eight nodes
S DR=""
S DR=DR_"205////^S X=BARTMP1(205)"
S DR=DR_";206////^S X=BARTMP1(206)"
S DR=DR_";207////^S X=BARTMP1(207)"
S DR=DR_";702///^S X=@BAR3PUP@(""POLN"")"
S DR=DR_";701///^S X=@BAR3PUP@(""POLH"")"
I $G(@BAR3PUP@("OTHIDENT")) S DR=DR_";801////^S X=@BAR3PUP@(""OTHIDENT"")"
D ^DIE
K DIDEL
Q
; ************************
;
SETITM ;EP
; Create ITEM multiple for A/R Bill
N BARCNT,DR,DA,DIC,J,I
I '$D(BAR3PUP) D S3PUP
S DA(1)=BARBLDA
S DIC="^BARBL(DUZ(2),"_DA(1)_",3,"
S DIC(0)="LX"
S DIC("P")=$P(^DD(90050.01,301,0),U,2)
S DIC("DR")=""
;F I=1:1 S J=$T(TXT+I) Q:J="" S $P(DIC("DR"),";",I)=$P(J,"~",2)
;IHS/SD/TPF FIX ERROR IN CODE WHEN MSGTXT WAS ADDED IN PATCH 19
;ALSO ADDED ;;END TO END OF TXT TAG BAR*1.8*21
F I=1:1 S J=$T(TXT+I) Q:J[("END") S $P(DIC("DR"),";",I)=$P(J,"~",2)
S BARCNT=0
F S BARCNT=$O(@BAR3PUP@(BARCNT)) Q:'+BARCNT D
.S X=$G(@BAR3PUP@(BARCNT,"ITNM"))
.I '$L(X),$G(@BAR3PUP@(BARCNT,"BLSRV"))="REVENUE CODE" S (X,@BAR3PUP@(BARCNT,"ITNM"))="REVENUE CODE"
.Q:'$L(X)
.S X=""""_X_""""
.S @BAR3PUP@(BARCNT,"DOS")=$S(@BAR3PUP@(BARCNT,"DOS"):@BAR3PUP@(BARCNT,"DOS"),1:@BAR3PUP@("DOSB"))
.S Y=$G(@BAR3PUP@(BARCNT,"BLSRV"))
.S BARBLSRV=89 ; Default
.S:Y="PHARMARCY" BARBLSRV=83
.S:Y="ROOM & BOARD" BARBLSRV=84
.S:Y="REVENUE CODE" BARBLSRV=84
.S:Y="MED/SURG PROCEDURE" BARBLSRV=82
.S:Y="MEDICAL PROCEDURES" BARBLSRV=85
.S:Y="DENTAL" BARBLSRV=86
.S:Y="RADIOLOGY" BARBLSRV=87
.S:Y="LABORATORY" BARBLSRV=91
.S:Y="ANESTHESIA" BARBLSRV=88
.K DD,DO
.D FILE^DICN ;;;I DUZ=838 W !,"--> SETITM FILE^DICN"
.K BARBLSRV
K DLAYGO
Q
; ************************
SETCOLL ;EP
; Create COLLECTION STATUS multiple for A/R Bill
N DR,DA,DIC,J,I
S DA(1)=BARBLDA
S DIC="^BARBL(DUZ(2),"_DA(1)_",9,"
S DIC(0)="LX"
S DIC("P")=$P(^DD(90050.01,901,0),U,2)
S DIC("DR")=""
S X=$G(@BAR3PUP@("DTAP"))_U_$G(@BAR3PUP@("BLAMT"))_U_"INITIAL BILL"_U_"0"
K DD,DO
D FILE^DICN
K DLAYGO
Q
; ************************
DELITM ;EP - For the reload of an A/R Bill from the 3P Bill,
;deleting all existing items
N DIK,DA
S DA(1)=BARBLDA
S DA=0
S DIK=$$DIC^XBDIQ1(90050.01)
S DIK=DIK_DA(1)_",3,"
F S DA=$O(^BARBL(DUZ(2),DA(1),"3",DA)) Q:'+DA D ^DIK ;;;I DUZ=838 W !,"--> ^DIK"
Q
; ************************
;
SETTX ;** create transaction
K DR
N DIC
S BARTT=$O(^BARTBL("B","BILL NEW",""))
I '+BARTT D NOTX(BARBLDA,"BILL NEW")
I +BARTT D
. S DR="3////^S X=@BAR3PUP@(""BLAMT"")"
. D NEWTX
;start old code IHS/SD/SDR HEAT118656 belcourt
;I @BAR3PUP@("CREDIT") D
;. S BARTT=$O(^BARTBL("B","3P CREDIT",""))
;. I '+BARTT D NOTX(BARBLDA,"3P CREDIT")
;. I +BARTT D
;. . S DR="2////^S X=$G(@BAR3PUP@(""CREDIT""))"
;. . D NEWTX
;end old code start new code HEAT118656
I @BAR3PUP@("CREDIT")&'$D(@BAR3PUP@("TRNS")) D
.S BARTT=$O(^BARTBL("B","3P CREDIT",""))
.I '+BARTT D NOTX(BARBLDA,"3P CREDIT")
.I +BARTT D
..S DR="2////^S X=$G(@BAR3PUP@(""CREDIT""))"
..D NEWTX
;
I $P($G(BAROPT)," ")="Upload" D
.K BARTT
.S DR="7////^S X=1"
.S DR=DR_";1001///^S X=BAROPT_"" ""_DT"
.D NEWTX
I $D(@BAR3PUP@("TRNS")) D
.K BARTT
.S BARTTYP=""
.F S BARTTYP=$O(@BAR3PUP@("TRNS",BARTTYP)) Q:$G(BARTTYP)="" D
..S BARTCNT=0
..F S BARTCNT=$O(@BAR3PUP@("TRNS",BARTTYP,BARTCNT)) Q:'BARTCNT D
...S BARTAC=$O(^BAR(90052.01,"B",BARTTYP,0))
...I '+BARTAC D NOTX(BARBLDA,BARTTYP)
...I +BARTAC D
....;I BARTTYP'="PAYMENT CREDIT"&(BARTTYP'="GROUPER ALLOWANCE") S BARTT=$O(^BARTBL("B",BARTTYP,0))
....S BARAMT=+$G(@BAR3PUP@("TRNS",BARTTYP,BARTCNT))
....S (BARTRTYP,BARTT)=43
....S DR="2////^S X=+$G(@BAR3PUP@(""TRNS"",BARTTYP,BARTCNT))"
....S DR=DR_";101////^S X=BARTRTYP"
....S DR=DR_";102////^S X=BARTAC"
....I $P($G(@BAR3PUP@("TRNS",BARTTYP,BARTCNT)),U,5)'="" S DR=DR_";109////^S X=$P(@BAR3PUP@(""TRNS"",BARTTYP,BARTCNT),U,5)"
....I $P($G(@BAR3PUP@("TRNS",BARTTYP,BARTCNT)),U,4)'="" S DR=DR_";103////^S X=$P(@BAR3PUP@(""TRNS"",BARTTYP,BARTCNT),U,4)"
....D NEWTX
....;D 43^BARTDO
;end new code HEAT118656 belcourt
Q
; *************************
;
NEWTX ;
; Create A/R transaction
S BARTRIEN=$$NEW^BARTR()
S BARTT=$G(BARTT) ;
;I BARTRIEN<1 D NOTX(BARBLDA,BARTT) Q ;IHS/SD/SDR 10/10/13 HEAT135708
I BARTRIEN<1 D NOTX(BARBLDA,"") Q ;IHS/SD/SDR 10/10/13 HEAT135708
S DIE="^BARTR(DUZ(2),"
S DA=BARTRIEN
S DR=DR_";4////^S X=BARBLDA"
S DR=DR_";5////^S X=@BAR3PUP@(""PTNM"")"
S DR=DR_";6////^S X=BARACEIN"
S DR=DR_";8////^S X=BARPAR"
S DR=DR_";10////^S X=BARSERV"
S DR=DR_";11////^S X=BARSAT"
S DR=DR_";12////^S X=$P(BARTRIEN,""."")"
S DR=DR_";101////^S X=BARTT"
;start old code IHS/SD/SDR belcourt HEAT118656
;I $P($G(BAROPT)," ")="Upload" D
;. S DR=DR_";7////^S X=1"
;. S DR=DR_";1001///^S X=BAROPT_"" ""_DT"
;new old code HEAT118656
S DIDEL=90050
D ^DIE
K DIDEL
D TR^BARTDO(BARTRIEN) ;Update other files
Q
; *************************
;
NOTX(X,BARTYP) ;
; Couldn't create transaction.
N XVAL
I BARTYP="" S BARTYP="<UNK MSG>" ; P.OTT
S XVAL=$$GET1^DIQ(900501.01,X,.01)
W *7,$$CJ^XLFSTR("Could not create a "_BARTYP_" transaction.",IOM)
W $$CJ^XLFSTR("Please contact IT support.",IOM)
Q
; ************************
;
; This is a new section to build the DIC("DR") string
;BAR/SD/TPF BAR*1.8*21 ADDED LICN FOR 5010 SPEC PAGE 16
TXT ;
;;~2////^S X=$G(@BAR3PUP@(BARCNT,"DOS"))
;;~3////^S X=$G(@BAR3PUP@(BARCNT,"ITCODE"))
;;~4////^S X=$G(@BAR3PUP@(BARCNT,"OTIT"))
;;~5////^S X=$G(@BAR3PUP@(BARCNT,"OTUC"))
;;~6////^S X=$G(BARBLSRV)
;;~7////^S X=$G(@BAR3PUP@(BARCNT,"ITQT"))
;;~8////^S X=$G(@BAR3PUP@(BARCNT,"ITUI"))
;;~9////^S X=$G(@BAR3PUP@(BARCNT,"ITUC"))
;;~11////^S X=$G(BARCNT)
;;~12////^S X=$G(@BAR3PUP@(BARCNT,"LICN"))
;;~Q;10////^S X=$G(@BAR3PUP@(BARCNT,"ITTOT"))
;;END
;IHS/SD/AR BAR*1.8*19 06.17.2010
MSGTX ;
; Create A/R message transaction
N BARSCODE,BARGCN,BARSAT,BARCKEX,BARDATE
S BARGCN=$G(@BAR3PUP@(74,BARMIEN,"GCN"))
S BARSAT=$G(@BAR3PUP@("VSLC"))
S BARSCODE=$G(@BAR3PUP@(74,BARMIEN,"STAT"))
S BARUSER=$G(@BAR3PUP@(74,BARMIEN,"USR"))
S BARDATE=$G(@BAR3PUP@(74,BARMIEN,"DT"))
S BARRSN=$S($D(@BAR3PUP@(74,BARMIEN,"RSN")):@BAR3PUP@(74,BARMIEN,"RSN"),1:"NO MESSAGE")
D CKEXIST
Q:$G(BARCKEX)=1
D STATCODE
S BARTRIEN=$$NEW^BARTR()
I BARTRIEN<1 D NOTX(BARBLDA,BARTT) Q
S DIE="^BARTR(DUZ(2),"
S DA=BARTRIEN
S DR=DR_";7////^S X=1"
S DR=DR_";4////^S X=BARBLDA"
S DR=DR_";10////^S X=""BUSINESS OFFICE"""
S DR=DR_";11////^S X=BARSAT"
S DR=DR_";12////^S X=$P(BARTRIEN,""."")"
S DR=DR_";13////^S X=BARUSER"
S DR=DR_";16////^S X=""PRIMARY"""
S Y=BARTRIEN X ^DD("DD")
K ^TMP($J,"WP")
S ^TMP($J,"WP",1)=BARSCODE_" ON "_BARDATE_", GCN: "_BARGCN
S ^TMP($J,"WP",2)="REASON: "_BARRSN
S DIDEL=90050
D ^DIE
K DIDEL
D WP^DIE(90050.03,BARTRIEN_",",1001,"","^TMP($J,""WP"")")
K ^TMP($J,"WP")
D TR^BARTDO(BARTRIEN) ; Update other files
Q
; *************************
;
STATCODE ;
; TRANSLATE STATUS CODE TO VALUE
S:BARSCODE="O" BARSCODE="ORIGINAL"
S:BARSCODE="S" BARSCODE="RESENT"
S:BARSCODE="F" BARSCODE="REFILE"
S:BARSCODE="C" BARSCODE="RECREATED"
Q
RSTATCOD ;
; TRANSLATE STATUS CODE TO VALUE
S:BARSCODE="ORIGINAL" BARSCODE="O"
S:BARSCODE="RESENT" BARSCODE="S"
S:BARSCODE="REFILE" BARSCODE="F"
S:BARSCODE="RECREATED" BARSCODE="C"
Q
CKEXIST ;
; LOOK FOR EXISTING ENTRIES
N BARWP,BARWP2
S BARWP="",BARCKEX=0,BARTRIEN=0,BARWP2=""
F S BARTRIEN=$O(^BARTR(DUZ(2),"AM4",BARBLDA,BARTRIEN)) Q:('+BARTRIEN)!(BARCKEX) D
. S BARWP=$$GET1^DIQ(90050.03,BARTRIEN,1001,,"BARWP")
. S:$D(BARWP(1))&($G(BARWP(1))["GCN") BARWP2=$P(BARWP(1)," ",5)
. S:$D(BARWP2)&(BARWP2?1.N)&(BARWP2=BARGCN) BARCKEX=1
Q ;-EOR-
BARUP1 ; IHS/SD/LSL - 3P UPLOAD CONTINUED DEC 5,1996 ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**1,19,21,24**;OCT 26, 2005;Build 69
+2 ;
+3 ; IHS/ASDS/LSL - 9/11/01 - Version 1.5 Patch 2 - Modified to
+4 ; accomodate Pharmacy POS. Passes RX through to Other Bill
+5 ; Identifier field.
+6 ;
+7 ; IHS/SD/LSL - 11/27/02 - V1.7 - QAA-1200-130051
+8 ; Modified to insert quit logic if error in creating a new
+9 ; transaction. Also inserted documentation.
+10 ;
+11 ; IHS/SD/LSL - 06/09/03 - V1.7 Patch 1
+12 ; If uploading bill (not created through 3P Claim Approval),
+13 ; create BILL NEW transaction with 3P Approval Date and populate
+14 ; Message and Text fields of transaction.
+15 ;
+16 ; IHS/SD/LSL - 08/21/03 - V1.7 Patch 2 - IM11348
+17 ; Allow for checking of existing manually entered bill. Avoid
+18 ; duplicate bills in AR.
+19 ;
+20 ; IHS/SD/LSL - 09/10/03 - V1.7 Patch 3 - IM11459
+21 ; Resolve creation of multiple bills in AR when print or reprint
+22 ; from 3P.
+23 ;
+24 ; IHS/SD/RTL - 04/28/05 - V1.8 Patch 1 - IM17271
+25 ; Dupilcate bills
+26 ;
+27 ; ************************
+28 ;
+29 ; Global changes for indirection global - ABMA to @BAR3PUP@
+30 ;
+31 ;** Upload from 3P BILL file to A/R BILL/IHS file
+32 ; ---- continuation from ^BARUP
+33 ;
+34 ;** This routine is intended to be called from the 3p billing module
+35 ; at the time an item is created in the 3P BILL file.
+36 ;
+37 ;** Calling this routine at the entry point TPB^BARUP(ABMA ARRAY)
+38 ; will create an entry in the A/R BILL/IHS file.
+39 ;
+40 ; *************************
+41 ; IHS/SD/SDR HEAT118656 belcourt JUNE 2013 - BAR*1.8*.24
+42 ; IHS/SD/SDR 10/10/13 HEAT135708 - BAR*1.8*.24
+43 ; *************************
+44 QUIT
UPLOAD ; EP
+1 ; Create a new in A/R Bill File based on 3P data
+2 IF '$DATA(BAR3PUP)
DO S3PUP
+3 ; See if bill already exists for this parent in A/R
DO LK2
+4 IF +BARBLDA>0
Begin DoDot:1
+5 DO UPDATE
+6 ; Already uploaded
IF BARXX
IF $GET(^TMP("BAR",$JOB,"BARUPCHK",$JOB))
Begin DoDot:2
+7 SET BARACT=$$CMP^BARUPCHK(BARBLDA)
+8 SET ^TMP($JOB,"BARXX")=BARXX
End DoDot:2
QUIT
+9 DO BILLOAD
End DoDot:1
+10 ; Bill not found, try adding it
IF +BARBLDA<1
DO ADD
+11 ; Could not find/add bill in A/R
IF +BARBLDA<1
DO NOT
+12 QUIT
+13 ; *************************
+14 ;
S3PUP ;set BAR3PUP variable
+1 SET BAR3PUP="^TMP($J,""ABMPASS"")"
+2 QUIT
+3 ; *************************
+4 ;
LK2 ;
+1 ; Try to find the 3PB bill under this parent in A/R
+2 NEW BARTMP
+3 SET BARBLDA=-1
+4 SET BARSNM=$PIECE(@BAR3PUP@("BLNM"),"-",1)
+5 SET BARNNM=+BARSNM_" "
+6 ;F S BARNNM=$O(^BARBL(DUZ(2),"B",BARNNM)) Q:((+$P(BARNNM,"-")'=+BARSNM)!(BARBLDA>0)) D
+7 ;IM17271
FOR
SET BARNNM=$ORDER(^BARBL(DUZ(2),"B",BARNNM))
IF (($EXTRACT(BARNNM,1,$LENGTH(+BARSNM))'=(+BARSNM))!(BARBLDA>0))
QUIT
Begin DoDot:1
+8 IF $PIECE(BARNNM,"-")'=BARSNM
QUIT
+9 SET BARTMP=0
+10 FOR
SET BARTMP=$ORDER(^BARBL(DUZ(2),"B",BARNNM,BARTMP))
IF ('+BARTMP!(BARBLDA>0))
QUIT
Begin DoDot:2
+11 ;3P IEN (DA)
IF $PIECE($GET(^BARBL(DUZ(2),BARTMP,0)),U,17)'=@BAR3PUP@("BLDA")
QUIT
+12 ;PATIENT DFN
IF $PIECE($GET(^BARBL(DUZ(2),BARTMP,1)),U)'=@BAR3PUP@("PTNM")
QUIT
+13 SET BARBLDA=BARTMP
End DoDot:2
End DoDot:1
+14 QUIT
+15 ; *************************
ADD ;
+1 ; Create entry in A/R Bill file
+2 SET DIC="^BARBL(DUZ(2),"
+3 SET DIC(0)="LX"
+4 SET X=@BAR3PUP@("BLNM")
+5 SET DLAYGO=90050
+6 KILL DD,DO
+7 DO FILE^DICN
+8 KILL DLAYGO
+9 IF +Y<1
QUIT
+10 SET BARBLDA=+Y
+11 ; Tell 3P where A/R put the bill
+12 SET ^TMP($JOB,"ABMPASS","ARLOC")=DUZ(2)_","_BARBLDA
+13 ;Add items from 3P to AR
DO BILLOAD
+14 ; Create BILL NEW transaction
DO SETTX
+15 QUIT
+16 ; *************************
+17 ;
NOT ;
+1 ; Write message
+2 IF $DATA(ZTQUEUED)
QUIT
+3 USE IO(0)
+4 WRITE !,@BAR3PUP@("BLNM"),?10,"BILL NOT FOUND NOR ADDED ???"
+5 USE IO
+6 QUIT
+7 ; *************************
+8 ;
UPDATE ;EP
+1 ; Update .01 field of A/R Bill
+2 KILL DR
+3 SET DIE="^BARBL(DUZ(2),"
+4 SET DA=BARBLDA
+5 IF @BAR3PUP@("BLNM")'=$PIECE(^BARBL(DUZ(2),DA,0),U)
Begin DoDot:1
+6 SET DR=".01///"_@BAR3PUP@("BLNM")
+7 DO ^DIE
End DoDot:1
+8 ;check if previously loaded
SET BARXX=$$GET1^DIQ(90050.01,BARBLDA,13)
+9 QUIT
+10 ; *************************
+11 ;
BILLOAD ;EP - called by barupchk
+1 ; add/reload item from 3P to A/R everytime
+2 IF '$DATA(BARXX)
Begin DoDot:1
+3 IF '$DATA(^TMP($JOB,"BARXX"))
QUIT
+4 IF $DATA(^TMP($JOB,"BARXX"))
Begin DoDot:2
+5 SET BARXX=^TMP($JOB,"BARXX")
+6 KILL ^TMP($JOB,"BARXX")
End DoDot:2
End DoDot:1
+7 IF '$DATA(BAR3PUP)
DO S3PUP
+8 ; Previously loaded
IF $GET(BARXX)
DO ITMRLOAD
QUIT
+9 ; Add top level A/R Bill data
DO BILLOAD2
+10 DO SETITM
+11 ;IHS/SD/AR 1.8*19 07182010
DO SETCOLL
+12 QUIT
+13 ; *************************
+14 ;
ITMRLOAD ;
+1 ; Bill previously loaded into A/R, delete old items and create new ones
+2 ; Delete Items
DO DELITM
+3 ; Create Items
DO SETITM
+4 ; -------------------------------
+5 ;
+6 ; Update 3P IEN, 3P DUZ(2), and export date on A/R Bill
+7 KILL DA,DIC,DIE,X,Y,DR
+8 SET DA=BARBLDA
+9 SET DIE="^BARBL(DUZ(2),"
+10 IF $LENGTH(@BAR3PUP@("BLDA"))
Begin DoDot:1
+11 SET DR="17////^S X=@BAR3PUP@(""BLDA"")"
+12 SET DR=DR_";22////^S X=BARDUZ2"
+13 IF $LENGTH(@BAR3PUP@("DTBILL"))
SET DR=DR_";19////^S X=@BAR3PUP@(""DTBILL"")"
+14 SET DIE=$$DIC^XBDIQ1(90050.01)
+15 DO ^DIE
End DoDot:1
+16 ; -------------------------------
+17 ;
+18 ; Write message
+19 IF $EXTRACT(IOST)'="C"
QUIT
+20 IF IOT'["TRM"
QUIT
+21 IF $DATA(ZTQUEUED)
QUIT
+22 WRITE !,@BAR3PUP@("BLNM")
+23 WRITE " Previously loaded .. deleting existing A/R Bill items",!
+24 WRITE !,@BAR3PUP@("BLNM")," Now adding 3P Bill items to A/R Bill",!
+25 QUIT
+26 ; *************************
+27 ;
BILLOAD2 ;
+1 ; Populate top level A/R Bill data
+2 SET @BAR3PUP@("BLAMT")=@BAR3PUP@("BLAMT")*100+.5\1/100
+3 ;S @BAR3PUP@("CURTOT")=@BAR3PUP@("BLAMT")-$G(@BAR3PUP@("CREDIT")) ;IHS/SD/SDR HEAT118656 belcourt
+4 ;IHS/SD/SDR HEAT118656 belcourt
SET @BAR3PUP@("CURTOT")=@BAR3PUP@("BLAMT")
+5 IF '$DATA(BARPAR)
QUIT
+6 SET DIE="^BARBL(DUZ(2),"
+7 SET DA=BARBLDA
+8 SET DIDEL=90050
+9 ; -------------------------------
DR01 ;
+1 ; Populate 1st half zero node
+2 SET DR=""
+3 SET DR=DR_"3////^S X=BARACEIN"
+4 SET DR=DR_";4////^S X=BARBLTYP"
+5 SET DR=DR_";8////^S X=BARPAR"
+6 SET DR=DR_";10////^S X=BARSERV"
+7 SET DR=DR_";11////3PU"
+8 SET DR=DR_";13////^S X=$G(@BAR3PUP@(""BLAMT""))"
+9 SET DR=DR_";15////^S X=$G(@BAR3PUP@(""CURTOT""))"
+10 ;IHS/SD/TPF BAR*1.8*21 5010 SPECS PAGE 16
SET DR=DR_";1001////^S X=$G(@BAR3PUP@(""LICN""))"
+11 DO ^DIE
+12 ; -------------------------------
DR02 ;
+1 ; Popolate 2nd half zero node
+2 SET DR=""
+3 SET DR=DR_"16////^S X=BARSTAT"
+4 SET DR=DR_";17///^S X=$G(@BAR3PUP@(""BLDA""))"
+5 SET DR=DR_";18////^S X=@BAR3PUP@(""DTAP"")"
+6 ;S DR=DR_";18////^S X=@BAR3PUP@(""DTAP"");Q"
+7 SET DR=DR_";19////^S X=@BAR3PUP@(""DTBILL"")"
+8 SET DR=DR_";20///^S X=@BAR3PUP@(""CREDIT"")"
+9 SET DR=DR_";22////^S X=BARDUZ2"
+10 DO ^DIE
+11 ; -------------------------------
DR11 ;
+1 ; Populate 1st half one node
+2 SET DR=""
+3 SET DR=DR_"101////^S X=$G(@BAR3PUP@(""PTNM""))"
+4 SET DR=DR_";102////^S X=$G(@BAR3PUP@(""DOSB""))"
+5 SET DR=DR_";103////^S X=$G(@BAR3PUP@(""DOSE""))"
+6 SET DR=DR_";105////^S X=BARSSN"
+7 SET DR=DR_";106////^S X=BARPTYP"
+8 SET DR=DR_";107////^S X=BARHRN"
+9 DO ^DIE
+10 ; -------------------------------
DR12 ;
+1 ; Populate 2nd half one node
+2 SET DR=""
+3 SET DR=DR_"108////^S X=BARSAT"
+4 SET DR=DR_";112////^S X=$G(@BAR3PUP@(""CLNC""))"
+5 SET DR=DR_";113////^S X=BARPRV"
+6 SET DR=DR_";114////^S X=$G(@BAR3PUP@(""VSTP""))"
+7 SET DR=DR_";115////^S X=BARPBEN"
+8 DO ^DIE
+9 ; -------------------------------
DR278 ;
+1 ; Popolate two, seven, and eight nodes
+2 SET DR=""
+3 SET DR=DR_"205////^S X=BARTMP1(205)"
+4 SET DR=DR_";206////^S X=BARTMP1(206)"
+5 SET DR=DR_";207////^S X=BARTMP1(207)"
+6 SET DR=DR_";702///^S X=@BAR3PUP@(""POLN"")"
+7 SET DR=DR_";701///^S X=@BAR3PUP@(""POLH"")"
+8 IF $GET(@BAR3PUP@("OTHIDENT"))
SET DR=DR_";801////^S X=@BAR3PUP@(""OTHIDENT"")"
+9 DO ^DIE
+10 KILL DIDEL
+11 QUIT
+12 ; ************************
+13 ;
SETITM ;EP
+1 ; Create ITEM multiple for A/R Bill
+2 NEW BARCNT,DR,DA,DIC,J,I
+3 IF '$DATA(BAR3PUP)
DO S3PUP
+4 SET DA(1)=BARBLDA
+5 SET DIC="^BARBL(DUZ(2),"_DA(1)_",3,"
+6 SET DIC(0)="LX"
+7 SET DIC("P")=$PIECE(^DD(90050.01,301,0),U,2)
+8 SET DIC("DR")=""
+9 ;F I=1:1 S J=$T(TXT+I) Q:J="" S $P(DIC("DR"),";",I)=$P(J,"~",2)
+10 ;IHS/SD/TPF FIX ERROR IN CODE WHEN MSGTXT WAS ADDED IN PATCH 19
+11 ;ALSO ADDED ;;END TO END OF TXT TAG BAR*1.8*21
+12 FOR I=1:1
SET J=$TEXT(TXT+I)
IF J[("END")
QUIT
SET $PIECE(DIC("DR"),";",I)=$PIECE(J,"~",2)
+13 SET BARCNT=0
+14 FOR
SET BARCNT=$ORDER(@BAR3PUP@(BARCNT))
IF '+BARCNT
QUIT
Begin DoDot:1
+15 SET X=$GET(@BAR3PUP@(BARCNT,"ITNM"))
+16 IF '$LENGTH(X)
IF $GET(@BAR3PUP@(BARCNT,"BLSRV"))="REVENUE CODE"
SET (X,@BAR3PUP@(BARCNT,"ITNM"))="REVENUE CODE"
+17 IF '$LENGTH(X)
QUIT
+18 SET X=""""_X_""""
+19 SET @BAR3PUP@(BARCNT,"DOS")=$SELECT(@BAR3PUP@(BARCNT,"DOS"):@BAR3PUP@(BARCNT,"DOS"),1:@BAR3PUP@("DOSB"))
+20 SET Y=$GET(@BAR3PUP@(BARCNT,"BLSRV"))
+21 ; Default
SET BARBLSRV=89
+22 IF Y="PHARMARCY"
SET BARBLSRV=83
+23 IF Y="ROOM & BOARD"
SET BARBLSRV=84
+24 IF Y="REVENUE CODE"
SET BARBLSRV=84
+25 IF Y="MED/SURG PROCEDURE"
SET BARBLSRV=82
+26 IF Y="MEDICAL PROCEDURES"
SET BARBLSRV=85
+27 IF Y="DENTAL"
SET BARBLSRV=86
+28 IF Y="RADIOLOGY"
SET BARBLSRV=87
+29 IF Y="LABORATORY"
SET BARBLSRV=91
+30 IF Y="ANESTHESIA"
SET BARBLSRV=88
+31 KILL DD,DO
+32 ;;;I DUZ=838 W !,"--> SETITM FILE^DICN"
DO FILE^DICN
+33 KILL BARBLSRV
End DoDot:1
+34 KILL DLAYGO
+35 QUIT
+36 ; ************************
SETCOLL ;EP
+1 ; Create COLLECTION STATUS multiple for A/R Bill
+2 NEW DR,DA,DIC,J,I
+3 SET DA(1)=BARBLDA
+4 SET DIC="^BARBL(DUZ(2),"_DA(1)_",9,"
+5 SET DIC(0)="LX"
+6 SET DIC("P")=$PIECE(^DD(90050.01,901,0),U,2)
+7 SET DIC("DR")=""
+8 SET X=$GET(@BAR3PUP@("DTAP"))_U_$GET(@BAR3PUP@("BLAMT"))_U_"INITIAL BILL"_U_"0"
+9 KILL DD,DO
+10 DO FILE^DICN
+11 KILL DLAYGO
+12 QUIT
+13 ; ************************
DELITM ;EP - For the reload of an A/R Bill from the 3P Bill,
+1 ;deleting all existing items
+2 NEW DIK,DA
+3 SET DA(1)=BARBLDA
+4 SET DA=0
+5 SET DIK=$$DIC^XBDIQ1(90050.01)
+6 SET DIK=DIK_DA(1)_",3,"
+7 ;;;I DUZ=838 W !,"--> ^DIK"
FOR
SET DA=$ORDER(^BARBL(DUZ(2),DA(1),"3",DA))
IF '+DA
QUIT
DO ^DIK
+8 QUIT
+9 ; ************************
+10 ;
SETTX ;** create transaction
+1 KILL DR
+2 NEW DIC
+3 SET BARTT=$ORDER(^BARTBL("B","BILL NEW",""))
+4 IF '+BARTT
DO NOTX(BARBLDA,"BILL NEW")
+5 IF +BARTT
Begin DoDot:1
+6 SET DR="3////^S X=@BAR3PUP@(""BLAMT"")"
+7 DO NEWTX
End DoDot:1
+8 ;start old code IHS/SD/SDR HEAT118656 belcourt
+9 ;I @BAR3PUP@("CREDIT") D
+10 ;. S BARTT=$O(^BARTBL("B","3P CREDIT",""))
+11 ;. I '+BARTT D NOTX(BARBLDA,"3P CREDIT")
+12 ;. I +BARTT D
+13 ;. . S DR="2////^S X=$G(@BAR3PUP@(""CREDIT""))"
+14 ;. . D NEWTX
+15 ;end old code start new code HEAT118656
+16 IF @BAR3PUP@("CREDIT")&'$DATA(@BAR3PUP@("TRNS"))
Begin DoDot:1
+17 SET BARTT=$ORDER(^BARTBL("B","3P CREDIT",""))
+18 IF '+BARTT
DO NOTX(BARBLDA,"3P CREDIT")
+19 IF +BARTT
Begin DoDot:2
+20 SET DR="2////^S X=$G(@BAR3PUP@(""CREDIT""))"
+21 DO NEWTX
End DoDot:2
End DoDot:1
+22 ;
+23 IF $PIECE($GET(BAROPT)," ")="Upload"
Begin DoDot:1
+24 KILL BARTT
+25 SET DR="7////^S X=1"
+26 SET DR=DR_";1001///^S X=BAROPT_"" ""_DT"
+27 DO NEWTX
End DoDot:1
+28 IF $DATA(@BAR3PUP@("TRNS"))
Begin DoDot:1
+29 KILL BARTT
+30 SET BARTTYP=""
+31 FOR
SET BARTTYP=$ORDER(@BAR3PUP@("TRNS",BARTTYP))
IF $GET(BARTTYP)=""
QUIT
Begin DoDot:2
+32 SET BARTCNT=0
+33 FOR
SET BARTCNT=$ORDER(@BAR3PUP@("TRNS",BARTTYP,BARTCNT))
IF 'BARTCNT
QUIT
Begin DoDot:3
+34 SET BARTAC=$ORDER(^BAR(90052.01,"B",BARTTYP,0))
+35 IF '+BARTAC
DO NOTX(BARBLDA,BARTTYP)
+36 IF +BARTAC
Begin DoDot:4
+37 ;I BARTTYP'="PAYMENT CREDIT"&(BARTTYP'="GROUPER ALLOWANCE") S BARTT=$O(^BARTBL("B",BARTTYP,0))
+38 SET BARAMT=+$GET(@BAR3PUP@("TRNS",BARTTYP,BARTCNT))
+39 SET (BARTRTYP,BARTT)=43
+40 SET DR="2////^S X=+$G(@BAR3PUP@(""TRNS"",BARTTYP,BARTCNT))"
+41 SET DR=DR_";101////^S X=BARTRTYP"
+42 SET DR=DR_";102////^S X=BARTAC"
+43 IF $PIECE($GET(@BAR3PUP@("TRNS",BARTTYP,BARTCNT)),U,5)'=""
SET DR=DR_";109////^S X=$P(@BAR3PUP@(""TRNS"",BARTTYP,BARTCNT),U,5)"
+44 IF $PIECE($GET(@BAR3PUP@("TRNS",BARTTYP,BARTCNT)),U,4)'=""
SET DR=DR_";103////^S X=$P(@BAR3PUP@(""TRNS"",BARTTYP,BARTCNT),U,4)"
+45 DO NEWTX
+46 ;D 43^BARTDO
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+47 ;end new code HEAT118656 belcourt
+48 QUIT
+49 ; *************************
+50 ;
NEWTX ;
+1 ; Create A/R transaction
+2 SET BARTRIEN=$$NEW^BARTR()
+3 ;
SET BARTT=$GET(BARTT)
+4 ;I BARTRIEN<1 D NOTX(BARBLDA,BARTT) Q ;IHS/SD/SDR 10/10/13 HEAT135708
+5 ;IHS/SD/SDR 10/10/13 HEAT135708
IF BARTRIEN<1
DO NOTX(BARBLDA,"")
QUIT
+6 SET DIE="^BARTR(DUZ(2),"
+7 SET DA=BARTRIEN
+8 SET DR=DR_";4////^S X=BARBLDA"
+9 SET DR=DR_";5////^S X=@BAR3PUP@(""PTNM"")"
+10 SET DR=DR_";6////^S X=BARACEIN"
+11 SET DR=DR_";8////^S X=BARPAR"
+12 SET DR=DR_";10////^S X=BARSERV"
+13 SET DR=DR_";11////^S X=BARSAT"
+14 SET DR=DR_";12////^S X=$P(BARTRIEN,""."")"
+15 SET DR=DR_";101////^S X=BARTT"
+16 ;start old code IHS/SD/SDR belcourt HEAT118656
+17 ;I $P($G(BAROPT)," ")="Upload" D
+18 ;. S DR=DR_";7////^S X=1"
+19 ;. S DR=DR_";1001///^S X=BAROPT_"" ""_DT"
+20 ;new old code HEAT118656
+21 SET DIDEL=90050
+22 DO ^DIE
+23 KILL DIDEL
+24 ;Update other files
DO TR^BARTDO(BARTRIEN)
+25 QUIT
+26 ; *************************
+27 ;
NOTX(X,BARTYP) ;
+1 ; Couldn't create transaction.
+2 NEW XVAL
+3 ; P.OTT
IF BARTYP=""
SET BARTYP="<UNK MSG>"
+4 SET XVAL=$$GET1^DIQ(900501.01,X,.01)
+5 WRITE *7,$$CJ^XLFSTR("Could not create a "_BARTYP_" transaction.",IOM)
+6 WRITE $$CJ^XLFSTR("Please contact IT support.",IOM)
+7 QUIT
+8 ; ************************
+9 ;
+10 ; This is a new section to build the DIC("DR") string
+11 ;BAR/SD/TPF BAR*1.8*21 ADDED LICN FOR 5010 SPEC PAGE 16
TXT ;
+1 ;;~2////^S X=$G(@BAR3PUP@(BARCNT,"DOS"))
+2 ;;~3////^S X=$G(@BAR3PUP@(BARCNT,"ITCODE"))
+3 ;;~4////^S X=$G(@BAR3PUP@(BARCNT,"OTIT"))
+4 ;;~5////^S X=$G(@BAR3PUP@(BARCNT,"OTUC"))
+5 ;;~6////^S X=$G(BARBLSRV)
+6 ;;~7////^S X=$G(@BAR3PUP@(BARCNT,"ITQT"))
+7 ;;~8////^S X=$G(@BAR3PUP@(BARCNT,"ITUI"))
+8 ;;~9////^S X=$G(@BAR3PUP@(BARCNT,"ITUC"))
+9 ;;~11////^S X=$G(BARCNT)
+10 ;;~12////^S X=$G(@BAR3PUP@(BARCNT,"LICN"))
+11 ;;~Q;10////^S X=$G(@BAR3PUP@(BARCNT,"ITTOT"))
+12 ;;END
+13 ;IHS/SD/AR BAR*1.8*19 06.17.2010
MSGTX ;
+1 ; Create A/R message transaction
+2 NEW BARSCODE,BARGCN,BARSAT,BARCKEX,BARDATE
+3 SET BARGCN=$GET(@BAR3PUP@(74,BARMIEN,"GCN"))
+4 SET BARSAT=$GET(@BAR3PUP@("VSLC"))
+5 SET BARSCODE=$GET(@BAR3PUP@(74,BARMIEN,"STAT"))
+6 SET BARUSER=$GET(@BAR3PUP@(74,BARMIEN,"USR"))
+7 SET BARDATE=$GET(@BAR3PUP@(74,BARMIEN,"DT"))
+8 SET BARRSN=$SELECT($DATA(@BAR3PUP@(74,BARMIEN,"RSN")):@BAR3PUP@(74,BARMIEN,"RSN"),1:"NO MESSAGE")
+9 DO CKEXIST
+10 IF $GET(BARCKEX)=1
QUIT
+11 DO STATCODE
+12 SET BARTRIEN=$$NEW^BARTR()
+13 IF BARTRIEN<1
DO NOTX(BARBLDA,BARTT)
QUIT
+14 SET DIE="^BARTR(DUZ(2),"
+15 SET DA=BARTRIEN
+16 SET DR=DR_";7////^S X=1"
+17 SET DR=DR_";4////^S X=BARBLDA"
+18 SET DR=DR_";10////^S X=""BUSINESS OFFICE"""
+19 SET DR=DR_";11////^S X=BARSAT"
+20 SET DR=DR_";12////^S X=$P(BARTRIEN,""."")"
+21 SET DR=DR_";13////^S X=BARUSER"
+22 SET DR=DR_";16////^S X=""PRIMARY"""
+23 SET Y=BARTRIEN
XECUTE ^DD("DD")
+24 KILL ^TMP($JOB,"WP")
+25 SET ^TMP($JOB,"WP",1)=BARSCODE_" ON "_BARDATE_", GCN: "_BARGCN
+26 SET ^TMP($JOB,"WP",2)="REASON: "_BARRSN
+27 SET DIDEL=90050
+28 DO ^DIE
+29 KILL DIDEL
+30 DO WP^DIE(90050.03,BARTRIEN_",",1001,"","^TMP($J,""WP"")")
+31 KILL ^TMP($JOB,"WP")
+32 ; Update other files
DO TR^BARTDO(BARTRIEN)
+33 QUIT
+34 ; *************************
+35 ;
STATCODE ;
+1 ; TRANSLATE STATUS CODE TO VALUE
+2 IF BARSCODE="O"
SET BARSCODE="ORIGINAL"
+3 IF BARSCODE="S"
SET BARSCODE="RESENT"
+4 IF BARSCODE="F"
SET BARSCODE="REFILE"
+5 IF BARSCODE="C"
SET BARSCODE="RECREATED"
+6 QUIT
RSTATCOD ;
+1 ; TRANSLATE STATUS CODE TO VALUE
+2 IF BARSCODE="ORIGINAL"
SET BARSCODE="O"
+3 IF BARSCODE="RESENT"
SET BARSCODE="S"
+4 IF BARSCODE="REFILE"
SET BARSCODE="F"
+5 IF BARSCODE="RECREATED"
SET BARSCODE="C"
+6 QUIT
CKEXIST ;
+1 ; LOOK FOR EXISTING ENTRIES
+2 NEW BARWP,BARWP2
+3 SET BARWP=""
SET BARCKEX=0
SET BARTRIEN=0
SET BARWP2=""
+4 FOR
SET BARTRIEN=$ORDER(^BARTR(DUZ(2),"AM4",BARBLDA,BARTRIEN))
IF ('+BARTRIEN)!(BARCKEX)
QUIT
Begin DoDot:1
+5 SET BARWP=$$GET1^DIQ(90050.03,BARTRIEN,1001,,"BARWP")
+6 IF $DATA(BARWP(1))&($GET(BARWP(1))["GCN")
SET BARWP2=$PIECE(BARWP(1)," ",5)
+7 IF $DATA(BARWP2)&(BARWP2?1.N)&(BARWP2=BARGCN)
SET BARCKEX=1
End DoDot:1
+8 ;-EOR-
QUIT
