BARUFUT1 ; IHS/SD/TPF - UTILITIES 2 FOR UFMS ; 04/28/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,5,6,13,21,23,24**;OCT 26, 2005;Build 69
;;
;Modify patch number in filename so batches are formatted
;correctly by the HUB
;IHS/SD/POT MAR 2012 HEAT62222 ADDED GETDAY0(FORM)- BAR*1.8*.23
;IHS/SD/POT APR 2013 HEAT89920 BAR*1.8*.23
;IHS/SD/POT JUN 2013 belcourt HEAT118656 - BAR*1.8*.24
Q
;
RESENDF(NOSEND) ;EP - RESEND A FILE ALREADY CREATED ;
RESENDF1 N DIREC,DESTIP,ARGS,BARUFMS
S DIREC=$P($G(^BAR(90052.06,DUZ(2),DUZ(2),15)),U) ;A/R PARAMETER FILE, UFMS DIRECTORY
I DIREC="" D Q
.W !!,"Before UFMS files can be created a non-public directory must be created"
.W !,"on the Host File System. This directory must be entered in to A/R Site Parameter"
.W !,"field UFMS DIRECTORY using the 'SPE Site Parameter Edit' option"
.D ASKFORRT^BARUFUT
W !!,"CURRENT UFMS DIRECTORY IS ",DIREC
W !
K DIR
S DIR(0)="FO"
S DIR("?",1)="Enter a file name e.g. IHS_AR_RPMS_RCV_398_113510_20070806_0847.DAT,"
S DIR("?",2)="or a partial filename IHS_AR_RPMS_RCV_398*, the * is a wildcard,"
S DIR("?")="or * to list all UFMS files in the UFMS directory."
I $G(NOSEND) S DIR("A")="List File(s)" ;
E S DIR("A")="Enter filename to be resent"
D ^DIR
Q:$D(DTOUT)!$D(DIROUT)!$D(DUOUT)!(Y="")!(Y=" ")
S FILENM=Y
I $E(FILENM,1,16)="IHS_TPB_RPMS_INV" W " ??" H 1 G RESENDF1
I FILENM="*" S FILENM="IHS_AR_RPMS_RCV*"
K FARRAY
D LIST^%ZISH(DIREC,FILENM,.FARRAY)
I '$D(FARRAY) W " ??" G RESENDF1
W @IOF
W !!!,"FILES FOUND: "
S (KEY,LN,CHOICE)=""
S FIRST=1
F CNT=1:1 S LN=$O(FARRAY(LN)) Q:KEY!(LN="")!$G(CHOICE) D
.W !,LN
.W ?5,FARRAY(LN)
.I '(CNT#10) D
..K DIR
..I $G(NOSEND) W ! S DIR(0)="E" D ^DIR S CHOICE=X=U Q I 1 ;
..E D
...S DIR(0)="NO^1:"_CNT
...S DIR("A")="Enter item number: "
...D ^DIR
..S CHOICE=Y
..S KEY=$D(DUOUT)!($D(DTOUT))
Q:KEY
I '$G(CHOICE),LN="" D Q:KEY
.K DIR
.I $G(NOSEND) W ! S DIR(0)="E" D ^DIR S CHOICE=X=U Q I 1 ;
.E D
..S DIR(0)="NO^1:"_(CNT-1)
..S DIR("A")="Enter item number: "
..D ^DIR
.S CHOICE=Y
.S KEY=$D(DUOUT)!($D(DTOUT))!(Y="")
;
I $G(NOSEND) Q ;
S ITEM=CHOICE
W !!,"You have selected "_$G(FARRAY(ITEM))
K DIR
S DIR(0)="YO"
S DIR("A")="Do you want to resend the file now?"
S DIR("B")="Y"
D ^DIR
G:$D(DTOUT)!$D(DUOUT)!('Y) RESENDF1
K RT
S RT=$$SENDTO1^ZISHMSMU("BAR UFMS F",DIREC_FARRAY(ITEM))
W !,DIREC_FARRAY(ITEM)
I $D(RT) W !!,"File has been "_$P(RT,U,2) W:$P($G(RT),U)=0 " and successfully sent."
I '$D(RT) W !!,"Problem encountered sending file!"
D ASKFORRT^BARUFUT
G RESENDF1
Q
;
ERASTAT(UDUZ,SESSID,ERASTAT) ;EP - SET ERA POSTING STATUS
;STATUS=1 CASHIER IS IN ERA POSTING
;STATUS=0 NOT IN ERA POSTING
;
K DIR,DIE,DIC,DA,DR
S DA(1)=UDUZ
S DA=SESSID
S DR=".04///^S X=ERASTAT"
S DIE="^BARSESS(DUZ(2),"_DA(1)_",11,"
D ^DIE
Q 1
STILPOST(UDUZ) ;EP - IS THE USER STILL LOGGED ON AND/OR POSTING?
N LOGIN,LOGIEN,LASTOPT,XUTLIEN,INMENUS,BARMENU
S LOGIN=$O(^XUSEC(0,"CUR",UDUZ,DT))
Q:'LOGIN 0_U_"NOT LOGGED IN" ;THEREFORE NOT POSTING
;
S INMENUS=0
S LOGIEN=DT ;just look at todays logins.
F S LOGIEN=$O(^XUSEC(0,"CUR",UDUZ,LOGIEN)) Q:'LOGIEN!(INMENUS) D
.S JOB=$P($G(^XUSEC(0,LOGIEN,0)),U,3)
.S CURREC=$G(^XUTL("XQ",JOB,"T"))
.Q:'CURREC
.;VALUE OF THE DEFAULT DIVISION TO THE USER NOT THE DIVISION THEY SIGN INTO.
.S CUROPT=$P($G(^XUTL("XQ",JOB,CURREC)),U,2)
.I $E(CUROPT,1,3)="BAR" D Q:INMENUS
..Q:CUROPT'[("BAR POST PAYMENTS")&(CUROPT'[("BAR POST ADJUSTMENTS"))&(CUROPT'[("BAR FLAT RATE POSTING"))&(CUROPT'[("BAR POST UC"))&(CUROPT'[("BAR POST REFUNDS"))&(CUROPT'[("BAR PST BENEFICIARY"))&(CUROPT'[("BAR ERA POST CLAIMS"))
..S INMENUS=1
..S BARMENU=$P($G(^XUTL("XQ",JOB,CURREC)),U,3)
I LOGIN,(INMENUS) Q 1_U_"LOGGED IN AND CURRENTLY IN THE '"_BARMENU_"' OPTION"
I LOGIN,('INMENUS) Q 2_U_"LOGGED IN BUT NOT CURRENTLY IN A/R MENUS"
Q 0_U_"UNKOWN"
;
CLEAR ;EP - CLEAR 'SESSION ALREADY ASSIGNED' FLAG
N REC,LINE,UDUZ,SESSID,PIECE,CHOICES,CHOICE
K CHOICE
I '$D(^BARSESS(DUZ(2),"D")) D Q
.W !!,"THERE ARE NO SESSION 'ALREADY ASSIGNED' FLAGS SET"
.D ASKFORRT^BARUFUT
.W @IOF
D CLRHDR
S UDUZ=""
F LINE=1:1 S UDUZ=$O(^BARSESS(DUZ(2),"D",1,UDUZ)) Q:'UDUZ D
.S SESSID=""
.F S SESSID=$O(^BARSESS(DUZ(2),"D",1,UDUZ,SESSID)) Q:'SESSID D
..W !,LINE,"."
..W ?3,$P($G(^VA(200,UDUZ,0)),U)
..S CHOICE(LINE)=UDUZ_U_SESSID
K DIR
W !
S LINE=LINE-1
S DIR(0)="LO^1:"_LINE
S DIR("A")="Select cashier(s) to clear"
D ^DIR
Q:Y=""!$D(DUOUT)!$D(DTOUT)
S CHOICES=Y
F PIECE=1:1 S LINE=$P(CHOICES,",",PIECE) Q:LINE="" D
.S X=$$DELFLG($P(CHOICE(LINE),U),$P(CHOICE(LINE),U,2))
.W !!!,"CASHIER ",$P($G(^VA(200,$P(CHOICE(LINE),U),0)),U)," HAS BEEN CLEARED" H 1
G CLEAR:$D(^BARSESS(DUZ(2),"D"))
W @IOF
Q
;
CLRHDR ;EP - CLEAR FLAG HEADER
W @IOF
W !!,$$CJ^XLFSTR("CLEAR 'SESSION ID ALRADY ASSIGNED' FLAG",IOM)
W !!!?10,"THE FOLLOWING USERS HAVE THIS FLAG SET"
W !!
Q
;
ASUFAC(DUZ2,TRANS) ;EP - GET ASUFACASUFAC3PIEN STRING
N IENS
S IENS=TRANS_","
S ARBILLIN=$$GET1^DIQ(90050.03,IENS,4,"I") ;A/R TRANSACTIONS, BILL (A/R) PTR
S ARDOSBEG=$$GET1^DIQ(90050.01,ARBILLIN_",",102,"I") ;A/R BILL, DOS BEGIN
S TPBIEN=$P($$FIND3PB^BARUTL(DUZ2,ARBILLIN),",",2) ;GET 3PIEN
S:TPBIEN="" TPBIEN="00000000"
;
S PARSUFAC=$$GET1^DIQ(90050.01,ARBILLIN_",",8,"I") ;A/R BILL, PARENT LOCATION
S PARSUFAC=$$CURASUFC(PARSUFAC,ARDOSBEG)
;
S LARSUFAC=$$GET1^DIQ(90050.01,ARBILLIN_",",108,"I") ;A/R BILL, VISIT LOCATION
S LARSUFAC=$$CURASUFC(LARSUFAC,ARDOSBEG)
Q PARSUFAC_LARSUFAC_TPBIEN
;
CURASUFC(LOCIEN,BARDOS) ;EP - GET CURRENT ASUFAC BASED ON 'DOS BEGIN' (#102) IN A/R BILL FILE
Q:LOCIEN="" "UNPOPL"
Q:BARDOS="" "UNPOPD"
N ASUFAC,BARDT,BARDTFLG
S ASUFAC=""
S BARDT=0
S BARDTFLG=0
S ASUFAC=$$GET1^DIQ(9999999.06,DUZ(2)_",",.12) ;First take it from 'asufac index" field
;if not, check class multiple
I 'ASUFAC D
.F S BARDT=$O(^AUTTLOC(LOCIEN,11,BARDT)) Q:BARDT=""!(BARDTFLG=1) D
..I BARDOS>$P($G(^AUTTLOC(LOCIEN,11,BARDT,0)),U) D
...S ASUFAC=$P($G(^AUTTLOC(LOCIEN,11,BARDT,0)),U,6)
...S BARDTFLG=1
Q ASUFAC
;
;
DELFLG(UDUZ,SESSID) ;EP - DELETE 'SESSION ID ALREADY ASSIGNED' FLAG
K DIR,DIE,DR,DIC,DA
S DA(1)=UDUZ
S DA=SESSID
S DR=".05///@"
S DIE="^BARSESS(DUZ(2),"_DA(1)_",11,"
D ^DIE
Q 1
;
GETDISLM(FORM) ;EP - GET 'UFMS DISPLAY DATE LIMIT'
N DISLIM
S FORM=$G(FORM)
S:FORM="" FORM="E"
I $G(STATUS)'["TRANSMITTED"&($G(XQSV)["BARZ MANAGER") Q ""
S DISLIM=$$GET1^DIQ(90052.06,DUZ(2)_",",1504,"I")
I DISLIM'="" S X=DISLIM,%DT="" D ^%DT S DISLIM=Y
I FORM="I" Q DISLIM
S Y=$P(DISLIM,".") X ^DD("DD") S DISLIM=Y
Q DISLIM
;
GETDAY0(FORM) ;EP - GET 'BOOKING DATE IN UFMS' ("DAY ZERO") ;HEAT # 62222 MAR 2012 - BAR*1.8*.23
N DISLIM
S FORM=$G(FORM)
S:FORM="" FORM="E"
S DISLIM=$$GET1^DIQ(90052.06,DUZ(2)_",",1505,"I")
I DISLIM'="" S X=DISLIM,%DT="" D ^%DT S DISLIM=Y
I FORM="I" Q DISLIM
S Y=$P(DISLIM,".") X ^DD("DD") S DISLIM=Y
Q DISLIM
RTCOUNT(UDUZ,SESSID) ;EP - RETURN NUMBER OF RETRANSMISSIONS
N DATETIME,RTCOUNT
S DATETIME=0
S RTCOUNT=0
F S DATETIME=$O(^BARSESS(DUZ(2),UDUZ,11,SESSID,1,DATETIME)) Q:'DATETIME D
.I $P($G(^BARSESS(DUZ(2),UDUZ,11,SESSID,1,DATETIME,0)),U,2)="RT" S RTCOUNT=RTCOUNT+1
Q RTCOUNT
;
RANGE(RANGE) ;EP - TAKE RANGE AND EXPAND IT 1,2,5-10,13,14
N PIECE,ITEM,NRANGE,CNT
S NRANGE=""
F PIECE=1:1 S ITEM=$P(RANGE,",",PIECE) Q:ITEM="" D
.I ITEM'[("-") S NRANGE=NRANGE_ITEM_"," Q
.S LOW=$P(ITEM,"-"),HIGH=$P(ITEM,"-",2)
.F CNT=LOW:1:HIGH S NRANGE=NRANGE_CNT_","
S NRANGE=","_NRANGE
Q NRANGE
;
EXCLLST(RANGE,LIST) ;EP - TAKE RANGE AND EXCLUDE FROM LIST IF NOT CHOSEN
N REC
S REC=""
F S REC=$O(LIST(REC)) Q:'REC D
.I RANGE'[(","_REC_",") K LIST(REC)
Q
;
CNTSTATS(STATCNTS,PERS) ;EP - COUNTS STATUSES ;BAR*1.8*4 IM26064
N DATELIM,STATUS,UDUZ
S STATUS=""
F S STATUS=$O(^BARSESS(DUZ(2),"C",STATUS)) Q:STATUS="" D
.S UDUZ=""
.F S UDUZ=$O(^BARSESS(DUZ(2),"C",STATUS,UDUZ)) Q:'UDUZ D
..I $D(PERS) Q:UDUZ'=PERS ;BAR*1.8*4 IM26064
..S DATELIM=$$GETDISLM("I")-.01
..F S DATELIM=$O(^BARSESS(DUZ(2),"C",STATUS,UDUZ,DATELIM)) Q:'DATELIM D
...Q:DATELIM<3101001 ;stops sessions prior to 10/1/08 from being counted bar*1.8*21 SDR
...S STATCNTS(STATUS)=$G(STATCNTS(STATUS))+1
...S STATCNTS("ALL STATUSES")=$G(STATCNTS("ALL STATUSES"))+1
Q
;
PRELIVE(AREAIEN,INSTYPE) ;EP - RETURN PRE 10/1/2007 APPLYTO FIELD BASED ON A/R ACCOUNT AND LOCATION
Q:$G(AREAIEN)=""&($G(INSTYPE)="") "UNKN UNKN "
N SUFFIX,PREFIX
S BAR08DT=$P($G(^BAR(90052.06,DUZ(2),DUZ(2),15)),U,5) ;IHS/SD/SDR bar*1.8*4 SCR100
S SUFFIX="",PREFIX=""
S SUFFIX=$$SUFFIX(U_INSTYPE_U)
S PREFIX=$$PREFIX(U_AREAIEN_U)
Q PREFIX_SUFFIX
;
SUFFIX(INSTYPE) ;EP - RETURN SUFFIX BASED ON INSTYPE
S PVTIN=U_"H"_U_"M"_U_"P"_U_"F"_U
S MCAID=U_"D"_U_"K"_U
S MCARE=U_"R"_U_"MD"_U_"MH"_U
S OTHER=U_"W"_U_"C"_U_"N"_U_"I"_U_"T"_U_"G"_U ;IHS/SD/SDR bar*1.8*4 bar*1.8*6
;S OTHER=U_"W"_U_"C"_U_"N"_U_"I"_U ;IHS/SD/SDR bar*1.8*4 bar*1.8*6
I PVTIN[INSTYPE Q "PVTIN"
I MCAID[INSTYPE Q "MCAID"
I MCARE[INSTYPE Q "MCARE"
I OTHER[INSTYPE Q "OTHER"
Q "UNDEF"
;
PREFIX(AREAIEN) ;EP - RETURN PREFIX BASED ON AREA
S ABR07=U_4_U ;BASED ON THE (#.04) AREA [4P:9999999.21] FIELD IN THE
S ABQ07=U_10_U ;LOCATION FILE.
S OKC07=U_18_U
S NAV07=U_34_U
S TUC07=U_1_U
S NAS07=U_19_U
S PHX07=U_25_U
S BEM07=U_5_U
S BIL07=U_16_U
S POR07=U_31_U
I (TPBAPDT<BAR08DT) G FY08
I ABR07[AREAIEN Q "ABR07"
I ABQ07[AREAIEN Q "ABQ07"
I OKC07[AREAIEN Q "OKC07"
I NAV07[AREAIEN Q "NAV07"
I TUC07[AREAIEN Q "TUC07"
I NAS07[AREAIEN Q "NAS07"
I PHX07[AREAIEN Q "PHX07"
I BEM07[AREAIEN Q "BEM07"
I BIL07[AREAIEN Q "BIL07"
I POR07[AREAIEN Q "POR07"
;
FY08 ;EP - SET PRELIVE PREFIX FOR 10/1/2008
;PRELIVE 10/1/2008
I ABR07[AREAIEN Q "ABR08"
I ABQ07[AREAIEN Q "ABQ08"
I OKC07[AREAIEN Q "OKC08"
I NAV07[AREAIEN Q "NAV08"
I TUC07[AREAIEN Q "TUC08"
I NAS07[AREAIEN Q "NAS08"
I PHX07[AREAIEN Q "PHX08"
I BEM07[AREAIEN Q "BEM08"
I BIL07[AREAIEN Q "BIL08"
I POR07[AREAIEN Q "POR08"
Q "UNDEF"
;
GETSUFAC() ;EP;GIVEN DUZ(2)
; 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:"")
S ASUFAC=$$CURASUFC(BARPAR,DT)
Q ASUFAC
;
DELETE(UDUZ,SESSID) ;EP - DELETE SESSION
K DIR,DIE,DIC,DR,DA
S DA(1)=UDUZ
S DA=SESSID
S DIK="^BARSESS(DUZ(2),"_DA(1)_",11,"
D ^DIK
W !,"Session ",SESSID," has been deleted for cashier ",$P($G(^VA(200,UDUZ,0)),U)
K DIR
D ASKFORRT^BARUFUT
Q
;
FILLSTR(STR,LENGTH,JUST,FILLER) ;EP - FILL STRING TO FIXED LENGTH
N FILL
S LENGTH=$G(LENGTH),JUST=$G(JUST)
S STR=$E(STR,1,LENGTH)
Q:$L(STR)=LENGTH STR
S $P(FILL,FILLER,LENGTH-$L(STR)+1)=""
I JUST="L" S STR=STR_FILL
E S STR=FILL_STR
Q STR
;dec=0 decimal implied
;just="L" left justified R=right justified
FILLDOL(DOL,LENGTH,JUST,DEC) ;EP - FILL DOLLAR AMT TO FIXED LENGTH
N FILL
I DOL<0 S DOL=$E(DOL,2,100000000)
S JUST=$$UPC^BARUTL(JUST)
S LENGTH=$G(LENGTH),JUST=$G(JUST),DEC=$G(DEC)=1
;LETS ADD THE RIGHT SIDE CUZ A/R DOESN'T STORE THE WHOLE NUMBER
I DOL'[(".") S DOL=DOL_"."
S:$P(DOL,".",2)="" DOL=DOL_"00"
S:$L($P(DOL,".",2))=1 DOL=DOL_"0"
I 'DEC S DOL=$TR(DOL,".")
S DOL=$E(DOL,1,LENGTH)
Q:$L(DOL)=LENGTH DOL
S $P(FILL,"0",LENGTH+1-$L(DOL))=""
I JUST="R" S DOL=FILL_DOL
E S DOL=DOL_FILL
Q DOL
;
ASKFNAME(BARFILE) ;EP - ASK FOR FILENAME
S BARFILE=$$GETFILNM()
W !!,"File will be created using the following name: ",BARFILE
Q 1
;
GETFILNM() ;EP - CREATE FILE NAME
N FNROOT,FNEXT,FN,YR,DATE,TIME,DATETIME,BARPK,BARPT,BARP2,BARP3
S FNROOT="IHS_AR_RPMS_RCV_"_DUZ_"_"_$$GETSUFAC()
S FNXREF=DUZ_"_"_$$GETSUFAC()
S BARV=$$VERSION^XPDUTL("BAR")
S BARP2=$$FILLSTR^BARUFUT1($P(BARV,".",2),2,"R","0")
S BARPK=$O(^DIC(9.4,"C","BAR",0))
S BARPK="IHS ACCOUNTS RECEIVABLE"
S BARPT=$$PATCH^BARUTL(BARPK,BARV) ;
S BARP3=$$FILLSTR^BARUFUT1(+BARPT,2,"R","0")
S FNXT=$P(BARV,".",1)_"."_BARP2_"."_BARP3
S FNEXT="_"_FNXT_".DAT"
S FN=FNROOT
GETFILAG ;BAR*1.8*4 CHECK FOR FILE NAME ALREADY USED
D NOW^%DTC
S YR=1700+$E(%,1,3)
S DATE=YR_$E(%,4,7)
S Y=% X ^DD("DD")
S TIME=$TR($P(Y,"@",2),":")
S:$L(TIME)=4 TIME=TIME_"00"
S DATETIME=DATE_"_"_TIME
I $D(^BARSESS(DUZ(2),"FN",FNXREF_"_"_DATETIME)) W !,"FILENAME ALREADY USED" H 2 G GETFILAG
S FN=FNROOT_"_"_DATETIME
S FN=FN_FNEXT
Q FN
;
SITECHK ;EP - CHECK DUZ(2) FOR SITE SET UP HEAT118656 BAR*1.8*.24
D SITECHK^BARUFUT4
Q
OUTOFORD(PARAM,OPTNAME) ;EP - PLACE OPTION OUT OF ORDER ;BAR*1.8*.23
Q:PARAM="NO"!(PARAM="") 0
N OPTIEN,BARMSG,BARXREF
S BARXREF="XXX"
S OPTIEN=$O(^DIC(19,"B",OPTNAME,""))
S $P(^DIC(19,BARXREF,DUZ(2),OPTIEN,0),U,3)="Option is disabled for this site" ;BAR*1.8*.23
;W !,"Cashiering menu options are now disabled for A/R Location: ",$P($G(^DIC(4,DUZ(2),0)),U) ;9/18/13
Q OPTIEN
;
ENABLORD(PARAM,OPTNAME) ;EP - ENABLE OPTION CASH SESS BAR*1.8*.23
Q:PARAM="YES" 0
N OPTIEN,BARXREF
S BARXREF="XXX"
S OPTIEN=$O(^DIC(19,"B",OPTNAME,""))
S $P(^DIC(19,BARXREF,DUZ(2),OPTIEN,0),U,3)=""
;W !,"Option now enabled for A/R Location: ",$P($G(^DIC(4,DUZ(2),0)),U) ;9/18/13
Q OPTIEN
ISENACS(BARDUZ) ;P.OTT - RETURNS 1 IF CASH SESS ENABLED
N BARXREF,OPTNAME
S OPTNAME="BAR UFMS CASHIERING MENU"
S BARXREF="XXX",OPTIEN=$O(^DIC(19,"B",OPTNAME,""))
Q $P($G(^DIC(19,BARXREF,BARDUZ,OPTIEN,0)),U,3)="" ;IF NIL - SESSIONS IS ENABLED
NEW BARRET
S BARRET=1
I '$$ISENACS(BARDUZ) S BARRET=0 W !!,"Out of order: Option is disabled for ",$P($G(^DIC(4,BARDUZ,0)),U),!! ;BAR*1.8*.23
Q BARRET
BARUFUT1 ; IHS/SD/TPF - UTILITIES 2 FOR UFMS ; 04/28/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,5,6,13,21,23,24**;OCT 26, 2005;Build 69
+2 ;;
+3 ;Modify patch number in filename so batches are formatted
+4 ;correctly by the HUB
+5 ;IHS/SD/POT MAR 2012 HEAT62222 ADDED GETDAY0(FORM)- BAR*1.8*.23
+6 ;IHS/SD/POT APR 2013 HEAT89920 BAR*1.8*.23
+7 ;IHS/SD/POT JUN 2013 belcourt HEAT118656 - BAR*1.8*.24
+8 QUIT
+9 ;
RESENDF(NOSEND) ;EP - RESEND A FILE ALREADY CREATED ;
RESENDF1 NEW DIREC,DESTIP,ARGS,BARUFMS
+1 ;A/R PARAMETER FILE, UFMS DIRECTORY
SET DIREC=$PIECE($GET(^BAR(90052.06,DUZ(2),DUZ(2),15)),U)
+2 IF DIREC=""
Begin DoDot:1
+3 WRITE !!,"Before UFMS files can be created a non-public directory must be created"
+4 WRITE !,"on the Host File System. This directory must be entered in to A/R Site Parameter"
+5 WRITE !,"field UFMS DIRECTORY using the 'SPE Site Parameter Edit' option"
+6 DO ASKFORRT^BARUFUT
End DoDot:1
QUIT
+7 WRITE !!,"CURRENT UFMS DIRECTORY IS ",DIREC
+8 WRITE !
+9 KILL DIR
+10 SET DIR(0)="FO"
+11 SET DIR("?",1)="Enter a file name e.g. IHS_AR_RPMS_RCV_398_113510_20070806_0847.DAT,"
+12 SET DIR("?",2)="or a partial filename IHS_AR_RPMS_RCV_398*, the * is a wildcard,"
+13 SET DIR("?")="or * to list all UFMS files in the UFMS directory."
+14 ;
IF $GET(NOSEND)
SET DIR("A")="List File(s)"
+15 IF '$TEST
SET DIR("A")="Enter filename to be resent"
+16 DO ^DIR
+17 IF $DATA(DTOUT)!$DATA(DIROUT)!$DATA(DUOUT)!(Y="")!(Y=" ")
QUIT
+18 SET FILENM=Y
+19 IF $EXTRACT(FILENM,1,16)="IHS_TPB_RPMS_INV"
WRITE " ??"
HANG 1
GOTO RESENDF1
+20 IF FILENM="*"
SET FILENM="IHS_AR_RPMS_RCV*"
+21 KILL FARRAY
+22 DO LIST^%ZISH(DIREC,FILENM,.FARRAY)
+23 IF '$DATA(FARRAY)
WRITE " ??"
GOTO RESENDF1
+24 WRITE @IOF
+25 WRITE !!!,"FILES FOUND: "
+26 SET (KEY,LN,CHOICE)=""
+27 SET FIRST=1
+28 FOR CNT=1:1
SET LN=$ORDER(FARRAY(LN))
IF KEY!(LN="")!$GET(CHOICE)
QUIT
Begin DoDot:1
+29 WRITE !,LN
+30 WRITE ?5,FARRAY(LN)
+31 IF '(CNT#10)
Begin DoDot:2
+32 KILL DIR
+33 ;
IF $GET(NOSEND)
WRITE !
SET DIR(0)="E"
DO ^DIR
SET CHOICE=X=U
QUIT
IF 1
+34 IF '$TEST
Begin DoDot:3
+35 SET DIR(0)="NO^1:"_CNT
+36 SET DIR("A")="Enter item number: "
+37 DO ^DIR
End DoDot:3
+38 SET CHOICE=Y
+39 SET KEY=$DATA(DUOUT)!($DATA(DTOUT))
End DoDot:2
End DoDot:1
+40 IF KEY
QUIT
+41 IF '$GET(CHOICE)
IF LN=""
Begin DoDot:1
+42 KILL DIR
+43 ;
IF $GET(NOSEND)
WRITE !
SET DIR(0)="E"
DO ^DIR
SET CHOICE=X=U
QUIT
IF 1
+44 IF '$TEST
Begin DoDot:2
+45 SET DIR(0)="NO^1:"_(CNT-1)
+46 SET DIR("A")="Enter item number: "
+47 DO ^DIR
End DoDot:2
+48 SET CHOICE=Y
+49 SET KEY=$DATA(DUOUT)!($DATA(DTOUT))!(Y="")
End DoDot:1
IF KEY
QUIT
+50 ;
+51 ;
IF $GET(NOSEND)
QUIT
+52 SET ITEM=CHOICE
+53 WRITE !!,"You have selected "_$GET(FARRAY(ITEM))
+54 KILL DIR
+55 SET DIR(0)="YO"
+56 SET DIR("A")="Do you want to resend the file now?"
+57 SET DIR("B")="Y"
+58 DO ^DIR
+59 IF $DATA(DTOUT)!$DATA(DUOUT)!('Y)
GOTO RESENDF1
+60 KILL RT
+61 SET RT=$$SENDTO1^ZISHMSMU("BAR UFMS F",DIREC_FARRAY(ITEM))
+62 WRITE !,DIREC_FARRAY(ITEM)
+63 IF $DATA(RT)
WRITE !!,"File has been "_$PIECE(RT,U,2)
IF $PIECE($GET(RT),U)=0
WRITE " and successfully sent."
+64 IF '$DATA(RT)
WRITE !!,"Problem encountered sending file!"
+65 DO ASKFORRT^BARUFUT
+66 GOTO RESENDF1
+67 QUIT
+68 ;
ERASTAT(UDUZ,SESSID,ERASTAT) ;EP - SET ERA POSTING STATUS
+1 ;STATUS=1 CASHIER IS IN ERA POSTING
+2 ;STATUS=0 NOT IN ERA POSTING
+3 ;
+4 KILL DIR,DIE,DIC,DA,DR
+5 SET DA(1)=UDUZ
+6 SET DA=SESSID
+7 SET DR=".04///^S X=ERASTAT"
+8 SET DIE="^BARSESS(DUZ(2),"_DA(1)_",11,"
+9 DO ^DIE
+10 QUIT 1
STILPOST(UDUZ) ;EP - IS THE USER STILL LOGGED ON AND/OR POSTING?
+1 NEW LOGIN,LOGIEN,LASTOPT,XUTLIEN,INMENUS,BARMENU
+2 SET LOGIN=$ORDER(^XUSEC(0,"CUR",UDUZ,DT))
+3 ;THEREFORE NOT POSTING
IF 'LOGIN
QUIT 0_U_"NOT LOGGED IN"
+4 ;
+5 SET INMENUS=0
+6 ;just look at todays logins.
SET LOGIEN=DT
+7 FOR
SET LOGIEN=$ORDER(^XUSEC(0,"CUR",UDUZ,LOGIEN))
IF 'LOGIEN!(INMENUS)
QUIT
Begin DoDot:1
+8 SET JOB=$PIECE($GET(^XUSEC(0,LOGIEN,0)),U,3)
+9 SET CURREC=$GET(^XUTL("XQ",JOB,"T"))
+10 IF 'CURREC
QUIT
+11 ;VALUE OF THE DEFAULT DIVISION TO THE USER NOT THE DIVISION THEY SIGN INTO.
+12 SET CUROPT=$PIECE($GET(^XUTL("XQ",JOB,CURREC)),U,2)
+13 IF $EXTRACT(CUROPT,1,3)="BAR"
Begin DoDot:2
+14 IF CUROPT'[("BAR POST PAYMENTS")&(CUROPT'[("BAR POST ADJUSTMENTS"))&(CUROPT'[("BAR FLAT RATE POSTING"))&(CUROPT'[("BAR POST UC"))&(CUROPT'[("BAR POST REFUNDS"))&(CUROPT'[("BAR PST BENEFICIARY"))&(CUROPT'[("BAR ERA POST CLAIMS"))
QUIT
+15 SET INMENUS=1
+16 SET BARMENU=$PIECE($GET(^XUTL("XQ",JOB,CURREC)),U,3)
End DoDot:2
IF INMENUS
QUIT
End DoDot:1
+17 IF LOGIN
IF (INMENUS)
QUIT 1_U_"LOGGED IN AND CURRENTLY IN THE '"_BARMENU_"' OPTION"
+18 IF LOGIN
IF ('INMENUS)
QUIT 2_U_"LOGGED IN BUT NOT CURRENTLY IN A/R MENUS"
+19 QUIT 0_U_"UNKOWN"
+20 ;
CLEAR ;EP - CLEAR 'SESSION ALREADY ASSIGNED' FLAG
+1 NEW REC,LINE,UDUZ,SESSID,PIECE,CHOICES,CHOICE
+2 KILL CHOICE
+3 IF '$DATA(^BARSESS(DUZ(2),"D"))
Begin DoDot:1
+4 WRITE !!,"THERE ARE NO SESSION 'ALREADY ASSIGNED' FLAGS SET"
+5 DO ASKFORRT^BARUFUT
+6 WRITE @IOF
End DoDot:1
QUIT
+7 DO CLRHDR
+8 SET UDUZ=""
+9 FOR LINE=1:1
SET UDUZ=$ORDER(^BARSESS(DUZ(2),"D",1,UDUZ))
IF 'UDUZ
QUIT
Begin DoDot:1
+10 SET SESSID=""
+11 FOR
SET SESSID=$ORDER(^BARSESS(DUZ(2),"D",1,UDUZ,SESSID))
IF 'SESSID
QUIT
Begin DoDot:2
+12 WRITE !,LINE,"."
+13 WRITE ?3,$PIECE($GET(^VA(200,UDUZ,0)),U)
+14 SET CHOICE(LINE)=UDUZ_U_SESSID
End DoDot:2
End DoDot:1
+15 KILL DIR
+16 WRITE !
+17 SET LINE=LINE-1
+18 SET DIR(0)="LO^1:"_LINE
+19 SET DIR("A")="Select cashier(s) to clear"
+20 DO ^DIR
+21 IF Y=""!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
+22 SET CHOICES=Y
+23 FOR PIECE=1:1
SET LINE=$PIECE(CHOICES,",",PIECE)
IF LINE=""
QUIT
Begin DoDot:1
+24 SET X=$$DELFLG($PIECE(CHOICE(LINE),U),$PIECE(CHOICE(LINE),U,2))
+25 WRITE !!!,"CASHIER ",$PIECE($GET(^VA(200,$PIECE(CHOICE(LINE),U),0)),U)," HAS BEEN CLEARED"
HANG 1
End DoDot:1
+26 IF $DATA(^BARSESS(DUZ(2),"D"))
GOTO CLEAR
+27 WRITE @IOF
+28 QUIT
+29 ;
CLRHDR ;EP - CLEAR FLAG HEADER
+1 WRITE @IOF
+2 WRITE !!,$$CJ^XLFSTR("CLEAR 'SESSION ID ALRADY ASSIGNED' FLAG",IOM)
+3 WRITE !!!?10,"THE FOLLOWING USERS HAVE THIS FLAG SET"
+4 WRITE !!
+5 QUIT
+6 ;
ASUFAC(DUZ2,TRANS) ;EP - GET ASUFACASUFAC3PIEN STRING
+1 NEW IENS
+2 SET IENS=TRANS_","
+3 ;A/R TRANSACTIONS, BILL (A/R) PTR
SET ARBILLIN=$$GET1^DIQ(90050.03,IENS,4,"I")
+4 ;A/R BILL, DOS BEGIN
SET ARDOSBEG=$$GET1^DIQ(90050.01,ARBILLIN_",",102,"I")
+5 ;GET 3PIEN
SET TPBIEN=$PIECE($$FIND3PB^BARUTL(DUZ2,ARBILLIN),",",2)
+6 IF TPBIEN=""
SET TPBIEN="00000000"
+7 ;
+8 ;A/R BILL, PARENT LOCATION
SET PARSUFAC=$$GET1^DIQ(90050.01,ARBILLIN_",",8,"I")
+9 SET PARSUFAC=$$CURASUFC(PARSUFAC,ARDOSBEG)
+10 ;
+11 ;A/R BILL, VISIT LOCATION
SET LARSUFAC=$$GET1^DIQ(90050.01,ARBILLIN_",",108,"I")
+12 SET LARSUFAC=$$CURASUFC(LARSUFAC,ARDOSBEG)
+13 QUIT PARSUFAC_LARSUFAC_TPBIEN
+14 ;
CURASUFC(LOCIEN,BARDOS) ;EP - GET CURRENT ASUFAC BASED ON 'DOS BEGIN' (#102) IN A/R BILL FILE
+1 IF LOCIEN=""
QUIT "UNPOPL"
+2 IF BARDOS=""
QUIT "UNPOPD"
+3 NEW ASUFAC,BARDT,BARDTFLG
+4 SET ASUFAC=""
+5 SET BARDT=0
+6 SET BARDTFLG=0
+7 ;First take it from 'asufac index" field
SET ASUFAC=$$GET1^DIQ(9999999.06,DUZ(2)_",",.12)
+8 ;if not, check class multiple
+9 IF 'ASUFAC
Begin DoDot:1
+10 FOR
SET BARDT=$ORDER(^AUTTLOC(LOCIEN,11,BARDT))
IF BARDT=""!(BARDTFLG=1)
QUIT
Begin DoDot:2
+11 IF BARDOS>$PIECE($GET(^AUTTLOC(LOCIEN,11,BARDT,0)),U)
Begin DoDot:3
+12 SET ASUFAC=$PIECE($GET(^AUTTLOC(LOCIEN,11,BARDT,0)),U,6)
+13 SET BARDTFLG=1
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT ASUFAC
+15 ;
+16 ;
DELFLG(UDUZ,SESSID) ;EP - DELETE 'SESSION ID ALREADY ASSIGNED' FLAG
+1 KILL DIR,DIE,DR,DIC,DA
+2 SET DA(1)=UDUZ
+3 SET DA=SESSID
+4 SET DR=".05///@"
+5 SET DIE="^BARSESS(DUZ(2),"_DA(1)_",11,"
+6 DO ^DIE
+7 QUIT 1
+8 ;
GETDISLM(FORM) ;EP - GET 'UFMS DISPLAY DATE LIMIT'
+1 NEW DISLIM
+2 SET FORM=$GET(FORM)
+3 IF FORM=""
SET FORM="E"
+4 IF $GET(STATUS)'["TRANSMITTED"&($GET(XQSV)["BARZ MANAGER")
QUIT ""
+5 SET DISLIM=$$GET1^DIQ(90052.06,DUZ(2)_",",1504,"I")
+6 IF DISLIM'=""
SET X=DISLIM
SET %DT=""
DO ^%DT
SET DISLIM=Y
+7 IF FORM="I"
QUIT DISLIM
+8 SET Y=$PIECE(DISLIM,".")
XECUTE ^DD("DD")
SET DISLIM=Y
+9 QUIT DISLIM
+10 ;
GETDAY0(FORM) ;EP - GET 'BOOKING DATE IN UFMS' ("DAY ZERO") ;HEAT # 62222 MAR 2012 - BAR*1.8*.23
+1 NEW DISLIM
+2 SET FORM=$GET(FORM)
+3 IF FORM=""
SET FORM="E"
+4 SET DISLIM=$$GET1^DIQ(90052.06,DUZ(2)_",",1505,"I")
+5 IF DISLIM'=""
SET X=DISLIM
SET %DT=""
DO ^%DT
SET DISLIM=Y
+6 IF FORM="I"
QUIT DISLIM
+7 SET Y=$PIECE(DISLIM,".")
XECUTE ^DD("DD")
SET DISLIM=Y
+8 QUIT DISLIM
RTCOUNT(UDUZ,SESSID) ;EP - RETURN NUMBER OF RETRANSMISSIONS
+1 NEW DATETIME,RTCOUNT
+2 SET DATETIME=0
+3 SET RTCOUNT=0
+4 FOR
SET DATETIME=$ORDER(^BARSESS(DUZ(2),UDUZ,11,SESSID,1,DATETIME))
IF 'DATETIME
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^BARSESS(DUZ(2),UDUZ,11,SESSID,1,DATETIME,0)),U,2)="RT"
SET RTCOUNT=RTCOUNT+1
End DoDot:1
+6 QUIT RTCOUNT
+7 ;
RANGE(RANGE) ;EP - TAKE RANGE AND EXPAND IT 1,2,5-10,13,14
+1 NEW PIECE,ITEM,NRANGE,CNT
+2 SET NRANGE=""
+3 FOR PIECE=1:1
SET ITEM=$PIECE(RANGE,",",PIECE)
IF ITEM=""
QUIT
Begin DoDot:1
+4 IF ITEM'[("-")
SET NRANGE=NRANGE_ITEM_","
QUIT
+5 SET LOW=$PIECE(ITEM,"-")
SET HIGH=$PIECE(ITEM,"-",2)
+6 FOR CNT=LOW:1:HIGH
SET NRANGE=NRANGE_CNT_","
End DoDot:1
+7 SET NRANGE=","_NRANGE
+8 QUIT NRANGE
+9 ;
EXCLLST(RANGE,LIST) ;EP - TAKE RANGE AND EXCLUDE FROM LIST IF NOT CHOSEN
+1 NEW REC
+2 SET REC=""
+3 FOR
SET REC=$ORDER(LIST(REC))
IF 'REC
QUIT
Begin DoDot:1
+4 IF RANGE'[(","_REC_",")
KILL LIST(REC)
End DoDot:1
+5 QUIT
+6 ;
CNTSTATS(STATCNTS,PERS) ;EP - COUNTS STATUSES ;BAR*1.8*4 IM26064
+1 NEW DATELIM,STATUS,UDUZ
+2 SET STATUS=""
+3 FOR
SET STATUS=$ORDER(^BARSESS(DUZ(2),"C",STATUS))
IF STATUS=""
QUIT
Begin DoDot:1
+4 SET UDUZ=""
+5 FOR
SET UDUZ=$ORDER(^BARSESS(DUZ(2),"C",STATUS,UDUZ))
IF 'UDUZ
QUIT
Begin DoDot:2
+6 ;BAR*1.8*4 IM26064
IF $DATA(PERS)
IF UDUZ'=PERS
QUIT
+7 SET DATELIM=$$GETDISLM("I")-.01
+8 FOR
SET DATELIM=$ORDER(^BARSESS(DUZ(2),"C",STATUS,UDUZ,DATELIM))
IF 'DATELIM
QUIT
Begin DoDot:3
+9 ;stops sessions prior to 10/1/08 from being counted bar*1.8*21 SDR
IF DATELIM<3101001
QUIT
+10 SET STATCNTS(STATUS)=$GET(STATCNTS(STATUS))+1
+11 SET STATCNTS("ALL STATUSES")=$GET(STATCNTS("ALL STATUSES"))+1
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
PRELIVE(AREAIEN,INSTYPE) ;EP - RETURN PRE 10/1/2007 APPLYTO FIELD BASED ON A/R ACCOUNT AND LOCATION
+1 IF $GET(AREAIEN)=""&($GET(INSTYPE)="")
QUIT "UNKN UNKN "
+2 NEW SUFFIX,PREFIX
+3 ;IHS/SD/SDR bar*1.8*4 SCR100
SET BAR08DT=$PIECE($GET(^BAR(90052.06,DUZ(2),DUZ(2),15)),U,5)
+4 SET SUFFIX=""
SET PREFIX=""
+5 SET SUFFIX=$$SUFFIX(U_INSTYPE_U)
+6 SET PREFIX=$$PREFIX(U_AREAIEN_U)
+7 QUIT PREFIX_SUFFIX
+8 ;
SUFFIX(INSTYPE) ;EP - RETURN SUFFIX BASED ON INSTYPE
+1 SET PVTIN=U_"H"_U_"M"_U_"P"_U_"F"_U
+2 SET MCAID=U_"D"_U_"K"_U
+3 SET MCARE=U_"R"_U_"MD"_U_"MH"_U
+4 ;IHS/SD/SDR bar*1.8*4 bar*1.8*6
SET OTHER=U_"W"_U_"C"_U_"N"_U_"I"_U_"T"_U_"G"_U
+5 ;S OTHER=U_"W"_U_"C"_U_"N"_U_"I"_U ;IHS/SD/SDR bar*1.8*4 bar*1.8*6
+6 IF PVTIN[INSTYPE
QUIT "PVTIN"
+7 IF MCAID[INSTYPE
QUIT "MCAID"
+8 IF MCARE[INSTYPE
QUIT "MCARE"
+9 IF OTHER[INSTYPE
QUIT "OTHER"
+10 QUIT "UNDEF"
+11 ;
PREFIX(AREAIEN) ;EP - RETURN PREFIX BASED ON AREA
+1 ;BASED ON THE (#.04) AREA [4P:9999999.21] FIELD IN THE
SET ABR07=U_4_U
+2 ;LOCATION FILE.
SET ABQ07=U_10_U
+3 SET OKC07=U_18_U
+4 SET NAV07=U_34_U
+5 SET TUC07=U_1_U
+6 SET NAS07=U_19_U
+7 SET PHX07=U_25_U
+8 SET BEM07=U_5_U
+9 SET BIL07=U_16_U
+10 SET POR07=U_31_U
+11 IF (TPBAPDT<BAR08DT)
GOTO FY08
+12 IF ABR07[AREAIEN
QUIT "ABR07"
+13 IF ABQ07[AREAIEN
QUIT "ABQ07"
+14 IF OKC07[AREAIEN
QUIT "OKC07"
+15 IF NAV07[AREAIEN
QUIT "NAV07"
+16 IF TUC07[AREAIEN
QUIT "TUC07"
+17 IF NAS07[AREAIEN
QUIT "NAS07"
+18 IF PHX07[AREAIEN
QUIT "PHX07"
+19 IF BEM07[AREAIEN
QUIT "BEM07"
+20 IF BIL07[AREAIEN
QUIT "BIL07"
+21 IF POR07[AREAIEN
QUIT "POR07"
+22 ;
FY08 ;EP - SET PRELIVE PREFIX FOR 10/1/2008
+1 ;PRELIVE 10/1/2008
+2 IF ABR07[AREAIEN
QUIT "ABR08"
+3 IF ABQ07[AREAIEN
QUIT "ABQ08"
+4 IF OKC07[AREAIEN
QUIT "OKC08"
+5 IF NAV07[AREAIEN
QUIT "NAV08"
+6 IF TUC07[AREAIEN
QUIT "TUC08"
+7 IF NAS07[AREAIEN
QUIT "NAS08"
+8 IF PHX07[AREAIEN
QUIT "PHX08"
+9 IF BEM07[AREAIEN
QUIT "BEM08"
+10 IF BIL07[AREAIEN
QUIT "BIL08"
+11 IF POR07[AREAIEN
QUIT "POR08"
+12 QUIT "UNDEF"
+13 ;
GETSUFAC() ;EP;GIVEN DUZ(2)
+1 ; get parent from parent/satellite file
+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 SET ASUFAC=$$CURASUFC(BARPAR,DT)
+17 QUIT ASUFAC
+18 ;
DELETE(UDUZ,SESSID) ;EP - DELETE SESSION
+1 KILL DIR,DIE,DIC,DR,DA
+2 SET DA(1)=UDUZ
+3 SET DA=SESSID
+4 SET DIK="^BARSESS(DUZ(2),"_DA(1)_",11,"
+5 DO ^DIK
+6 WRITE !,"Session ",SESSID," has been deleted for cashier ",$PIECE($GET(^VA(200,UDUZ,0)),U)
+7 KILL DIR
+8 DO ASKFORRT^BARUFUT
+9 QUIT
+10 ;
FILLSTR(STR,LENGTH,JUST,FILLER) ;EP - FILL STRING TO FIXED LENGTH
+1 NEW FILL
+2 SET LENGTH=$GET(LENGTH)
SET JUST=$GET(JUST)
+3 SET STR=$EXTRACT(STR,1,LENGTH)
+4 IF $LENGTH(STR)=LENGTH
QUIT STR
+5 SET $PIECE(FILL,FILLER,LENGTH-$LENGTH(STR)+1)=""
+6 IF JUST="L"
SET STR=STR_FILL
+7 IF '$TEST
SET STR=FILL_STR
+8 QUIT STR
+9 ;dec=0 decimal implied
+10 ;just="L" left justified R=right justified
FILLDOL(DOL,LENGTH,JUST,DEC) ;EP - FILL DOLLAR AMT TO FIXED LENGTH
+1 NEW FILL
+2 IF DOL<0
SET DOL=$EXTRACT(DOL,2,100000000)
+3 SET JUST=$$UPC^BARUTL(JUST)
+4 SET LENGTH=$GET(LENGTH)
SET JUST=$GET(JUST)
SET DEC=$GET(DEC)=1
+5 ;LETS ADD THE RIGHT SIDE CUZ A/R DOESN'T STORE THE WHOLE NUMBER
+6 IF DOL'[(".")
SET DOL=DOL_"."
+7 IF $PIECE(DOL,".",2)=""
SET DOL=DOL_"00"
+8 IF $LENGTH($PIECE(DOL,".",2))=1
SET DOL=DOL_"0"
+9 IF 'DEC
SET DOL=$TRANSLATE(DOL,".")
+10 SET DOL=$EXTRACT(DOL,1,LENGTH)
+11 IF $LENGTH(DOL)=LENGTH
QUIT DOL
+12 SET $PIECE(FILL,"0",LENGTH+1-$LENGTH(DOL))=""
+13 IF JUST="R"
SET DOL=FILL_DOL
+14 IF '$TEST
SET DOL=DOL_FILL
+15 QUIT DOL
+16 ;
ASKFNAME(BARFILE) ;EP - ASK FOR FILENAME
+1 SET BARFILE=$$GETFILNM()
+2 WRITE !!,"File will be created using the following name: ",BARFILE
+3 QUIT 1
+4 ;
GETFILNM() ;EP - CREATE FILE NAME
+1 NEW FNROOT,FNEXT,FN,YR,DATE,TIME,DATETIME,BARPK,BARPT,BARP2,BARP3
+2 SET FNROOT="IHS_AR_RPMS_RCV_"_DUZ_"_"_$$GETSUFAC()
+3 SET FNXREF=DUZ_"_"_$$GETSUFAC()
+4 SET BARV=$$VERSION^XPDUTL("BAR")
+5 SET BARP2=$$FILLSTR^BARUFUT1($PIECE(BARV,".",2),2,"R","0")
+6 SET BARPK=$ORDER(^DIC(9.4,"C","BAR",0))
+7 SET BARPK="IHS ACCOUNTS RECEIVABLE"
+8 ;
SET BARPT=$$PATCH^BARUTL(BARPK,BARV)
+9 SET BARP3=$$FILLSTR^BARUFUT1(+BARPT,2,"R","0")
+10 SET FNXT=$PIECE(BARV,".",1)_"."_BARP2_"."_BARP3
+11 SET FNEXT="_"_FNXT_".DAT"
+12 SET FN=FNROOT
GETFILAG ;BAR*1.8*4 CHECK FOR FILE NAME ALREADY USED
+1 DO NOW^%DTC
+2 SET YR=1700+$EXTRACT(%,1,3)
+3 SET DATE=YR_$EXTRACT(%,4,7)
+4 SET Y=%
XECUTE ^DD("DD")
+5 SET TIME=$TRANSLATE($PIECE(Y,"@",2),":")
+6 IF $LENGTH(TIME)=4
SET TIME=TIME_"00"
+7 SET DATETIME=DATE_"_"_TIME
+8 IF $DATA(^BARSESS(DUZ(2),"FN",FNXREF_"_"_DATETIME))
WRITE !,"FILENAME ALREADY USED"
HANG 2
GOTO GETFILAG
+9 SET FN=FNROOT_"_"_DATETIME
+10 SET FN=FN_FNEXT
+11 QUIT FN
+12 ;
SITECHK ;EP - CHECK DUZ(2) FOR SITE SET UP HEAT118656 BAR*1.8*.24
+1 DO SITECHK^BARUFUT4
+2 QUIT
OUTOFORD(PARAM,OPTNAME) ;EP - PLACE OPTION OUT OF ORDER ;BAR*1.8*.23
+1 IF PARAM="NO"!(PARAM="")
QUIT 0
+2 NEW OPTIEN,BARMSG,BARXREF
+3 SET BARXREF="XXX"
+4 SET OPTIEN=$ORDER(^DIC(19,"B",OPTNAME,""))
+5 ;BAR*1.8*.23
SET $PIECE(^DIC(19,BARXREF,DUZ(2),OPTIEN,0),U,3)="Option is disabled for this site"
+6 ;W !,"Cashiering menu options are now disabled for A/R Location: ",$P($G(^DIC(4,DUZ(2),0)),U) ;9/18/13
+7 QUIT OPTIEN
+8 ;
ENABLORD(PARAM,OPTNAME) ;EP - ENABLE OPTION CASH SESS BAR*1.8*.23
+1 IF PARAM="YES"
QUIT 0
+2 NEW OPTIEN,BARXREF
+3 SET BARXREF="XXX"
+4 SET OPTIEN=$ORDER(^DIC(19,"B",OPTNAME,""))
+5 SET $PIECE(^DIC(19,BARXREF,DUZ(2),OPTIEN,0),U,3)=""
+6 ;W !,"Option now enabled for A/R Location: ",$P($G(^DIC(4,DUZ(2),0)),U) ;9/18/13
+7 QUIT OPTIEN
ISENACS(BARDUZ) ;P.OTT - RETURNS 1 IF CASH SESS ENABLED
+1 NEW BARXREF,OPTNAME
+2 SET OPTNAME="BAR UFMS CASHIERING MENU"
+3 SET BARXREF="XXX"
SET OPTIEN=$ORDER(^DIC(19,"B",OPTNAME,""))
+4 ;IF NIL - SESSIONS IS ENABLED
QUIT $PIECE($GET(^DIC(19,BARXREF,BARDUZ,OPTIEN,0)),U,3)=""
+1 NEW BARRET
+2 SET BARRET=1
+3 ;BAR*1.8*.23
IF '$$ISENACS(BARDUZ)
SET BARRET=0
WRITE !!,"Out of order: Option is disabled for ",$PIECE($GET(^DIC(4,BARDUZ,0)),U),!!
+4 QUIT BARRET
