BARUFUT1.m

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 

CSMENU(BARDUZ) ;

 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 !!