Routine: BARDUTL

BARDUTL ; IHS/SD/LSL - DATE UTILITIES FOR A/R PACKAGE ;

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,6,28**;OCT 26, 2005;Build 92

 ; IHS/SD/LSL - 02/20/04 - V1.7 Patch 5 - REMARK CODES

 ;      New utility to read in string to local array for printing

 ; IHS/SD/LSL - 03/29/04 - V1.8

 ;      Added TRANS utility to find all $$ for specific trans type

 ;      on a bill.

 ; IHS/DIT/CPC - 20180427 CR9580 - Add Fileman to XML date conversion

 ; IHS/DIT/CPC - 20180427 CR5994 - Add utility to add wrapping break to a string at specified length.

 ; ********************************************************************

SDT(X) ; EP - Y is set to the printable date ##/##/## from X (fileman date)

N Y

 S Y=$S(+X>0:$E(X,4,5)_"/"_$E(X,6,7)_"/"_($E(X,1,3)+1700),1:"")  ;Y2000

Q Y

 ;start new code IHS/SD/SDR bar*1.8*6 4.1.3

 ; *********************************************************************

SHDT(X) ; EP - Y is set to the printable date ##/##/## from X (fileman date)

N Y

 S Y=$S(+X>0:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"")  ;Y2000

Q Y

 ;end new code bar*1.8*6

 ; *********************************************************************

HDT(X) ;EP - Y is set to the printable date ##-##-## from X (fileman date)

N Y

 S Y=$S(+X>0:$E(X,4,5)_"-"_$E(X,6,7)_"-"_($E(X,1,3)+1700),1:"")  ;Y2000

Q Y

 ; *********************************************************************

CDT(X) ;EP - Y= date/time ##/##/##@##:## from X (fm date) for display in claim editor

N Y

 I '+X S Y="" Q Y

 S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_($E(X,1,3)+1700)  ;Y2000

 I '$P(X,".",2) Q Y

 S BARTIME=$P(X,".",2)

 S BARTIME=BARTIME_"00"

 S Y=Y_"@"_$E(BARTIME,1,2)_":"_$E(BARTIME,3,4)

Q Y

 ; *********************************************************************

 ;Start new code IHS/DIT/CPC BAR*1.8*28 CR8345 HEAT224215

XDT(X)  ;EP - Y=XML date/time CCYYMMDDTHH:MM:SS.MSS

N Y

 I '+X S Y="" Q Y

 S Y=($E(X,1,3)+1700)_"-"_$E(X,4,5)_"-"_$E(X,6,7)_"T"

 I '$P(X,".",2) Q Y_"00:00:00.000"

 S BARTIME=$P(X,".",2)

 S BARTIME=BARTIME_"000000"

 S Y=Y_$E(BARTIME,1,2)_":"_$E(BARTIME,3,4)_":"_$E(BARTIME,5,6)_".000"

Q Y

 ; *********************************************************************

 ;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.4

TDT(X) ;EP - Y= date/time ##/##/##@##:##:## from X (fm date) for display of formatted trans date

N Y

 I '+X S Y="" Q Y

 S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_($E(X,1,3)+1700)

 I '$P(X,".",2) Q Y

 S BARTIME=$P(X,".",2)

 S BARTIME=BARTIME_"00"

 S Y=Y_"@"_$E(BARTIME,1,2)_":"_$E(BARTIME,3,4)_":"_$E(BARTIME,5,6)

Q Y

 ; *********************************************************************

 ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.4

MDT(X) ;EP - printable date and time in menu header format

 S BAR("DATE")=+$E(X,6,7)_"-"_$P($T(MTHS+1),";;",+$E(X,4,5)+1)_"-"_($E(X,1,3)+1700)  ;Y2000

 S BAR("TIME")=$P(X,".",2)

 I BAR("TIME")'="" D

 .S BAR("TIME")="."_BAR("TIME")

 .S BAR("TIME")=$E(X,8,15)+.0000001

 .S BAR("AMPM")=$S(BAR("TIME")>.1159999:"PM",1:"AM")

 .I BAR("TIME")>.1259999 S BAR("TIME")=BAR("TIME")-.12

 .S BAR("TIME")=+$E(BAR("TIME"),2,3)_":"_$E(BAR("TIME"),4,5)_" "_BAR("AMPM")

 .S BAR("TIME")=" "_BAR("TIME")

 S X=BAR("DATE")_BAR("TIME")

 K BAR("DATE"),BAR("TIME"),BAR("AMPM")

Q X

 ; *********************************************************************

MDT2(X) ;EP - printable date, letter format

 S X=+$E(X,6,7)_" "_$P($T(MTHS+1),";;",+$E(X,4,5)+1)_" "_($E(X,1,3)+1700)  ;Y2000

Q X

 ; *********************************************************************

Y2KDT(X) ;EP - date from fileman to Y2K format Y=MMDDCCYY

N Y

 I X="" Q X

 S Y=$E(X,4,7)_($E(X,1,3)+1700)

Q Y

 ; *********************************************************************

Y2KD2(X) ;EP - date from fileman to Y2K format Y=CCYYMMDD

N Y

 I X="" Q X

 S Y=($E(X,1,3)+1700)_$E(X,4,7)

Q Y

 ; *********************************************************************

MTHS ;MONTHS

 ;;JAN;;FEB;;MAR;;APR;;MAY;;JUN;;JUL;;AUG;;SEP;;OCT;;NOV;;DEC

 ; *********************************************************************

HRN(X) ;EP - Y is set to the printable HRN

 ;     for patient BARP("PDFN") at location BARP("LDFN")

 S Y=$S('$G(BARP("PDFN")):"[no PAT]",'$G(BARP("LDFN")):"[no LOC]",$D(^AUPNPAT(BARP("PDFN"),41,BARP("LDFN"),0)):"[HRN:"_$P(^(0),U,2)_"]",1:"[no HRN]")

Q Y

 ; *********************************************************************

CSZ(X) ;EP - Y is set to the printable City, State ZIP CODE

 ; X incoming variable must = CITY^ST^ZIP

 S Y=$S($G(X)="":"no address",$P(X,U)="":"no city",'$P(X,U,2):"no state",$P($G(^DIC(5,$P(X,U,2),0)),U,2)="":"invalid state",'$P(X,U,3):"no zip",1:$P(X,U)_", "_$P(^(0),U,2)_"  "_$P(X,U,3))

Q Y

 ; *********************************************************************

TM(X,Y) ;EP - FIGURE TOTAL MINUTES GIVEN FM DATE/TIMES IN X AND Y

 I X="" Q X

 I Y="" S X="" Q X

 D H^%DTC

 S BAR(1,1)=%H

 S BAR(1,2)=%T

 S X=Y

 D H^%DTC

 S BAR(2,1)=%H

 S BAR(2,2)=%T

 S BAR("D")=BAR(2,1)-BAR(1,1)*24*60*60

 S BAR("T")=BAR(2,2)-BAR(1,2)

 S BAR("TS")=BAR("D")+BAR("T")

 S X=BAR("TS")\60

Q X

 ; *********************************************************************

PAT(X) ;EP - DISPLAY PATIENT HEADER WITH IDENTIFIERS - X=DFN

 S $P(BAR("="),"=",80)=""

 W $$EN^BARVDF("IOF")

 W !,$$EN^BARVDF("RVN"),"PATIENT:",$$EN^BARVDF("RVF"),"  "

 S BAR("P0")=^DPT(X,0)

 W $P(BAR("P0"),"^",1),"     ",$P(BAR("P0"),"^",2)

 S BAR("DOB")=$P(BAR("P0"),"^",3)

 W "  ",$E(BAR("DOB"),4,5),"/",$E(BAR("DOB"),6,7),"/",($E(BAR("DOB"),1,3)+1700)  ;Y2000

 S BAR("SSN")=$P(BAR("P0"),"^",9)

 W "  ",$E(BAR("SSN"),1,3),"-",$E(BAR("SSN"),4,5),"-",$E(BAR("SSN"),6,9)

 W "  ","HRN: ",$P($G(^AUPNPAT(X,41,DUZ(2),0)),"^",2)

 W !,BAR("=")

 ; *********************************************************************

DATE(X) ;EP - ask beginning and ending date

 S %DT="AEP"

 S %DT("A")="Select "_$P("Beginning^Ending","^",X)_" Date: "

 D ^%DT

Q Y

 ; *********************************************************************

MSG(DATA,PRE,POST,BEEP)      ;EP; Writes line to device

 N X,Y

 I PRE>0 F I=1:1:PRE W !

 W DATA

 I POST>0 F I=1:1:POST W !

 I $G(BEEP)>0 F I=1:1:BEEP W $C(7)

 ; *********************************************************************

ARDAYS ; EP

 ; Computed field (File 90050.0204, Field .07)

 N I,J,BAREND,CBAREND

 S J=D1

 S BAREND=0

 F I=1:1:3 D  Q:'+J

 . S J=$O(^BARAC(DUZ(2),D0,4,J),-1)  ; Previous entry

 . Q:'+J

 . S BAR(0)=$G(^BARAC(DUZ(2),D0,4,J,0))

 . S BARTMP=$P(BAR(0),U,2)+$P(BAR(0),U,4)-$P(BAR(0),U,5)-$P(BAR(0),U,6)

 . S BAREND=BAREND+BARTMP

 I '+J S X="" Q

 S BAREND=BAREND/3

 S BAR(0)=$G(^BARAC(DUZ(2),D0,4,D1,0))

 S CBAREND=$P(BAR(0),U,2)+$P(BAR(0),U,4)-$P(BAR(0),U,5)-$P(BAR(0),U,6)

 S X=CBAREND/BAREND

 ; *********************************************************************

VARDAYS ; EP

 ; Computed field (File 90050.0205, Field .07)

 N I,J,BAREND,CBAREND

 S J=D2

 S BAREND=0

 F I=1:1:3 D  Q:'+J

 . S J=$O(^BARAC(DUZ(2),D0,4,D1,1,J),-1)  ; Previous entry

 . Q:'+J

 . S BAR(0)=$G(^BARAC(DUZ(2),D0,4,D1,1,J,0))

 . S BAREND=$P(BAR(0),U,2)+$P(BAR(0),U,4)-$P(BAR(0),U,5)-$P(BAR(0),U,6)

 I '+J S X="" Q

 S BAREND=BAREND/3

 S BAR(0)=$G(^BARAC(DUZ(2),D0,4,D1,1,D2,0))

 S CBAREND=$P(BAR(0),U,2)+$P(BAR(0),U,4)-$P(BAR(0),U,5)-$P(BAR(0),U,6)

 S X=CBAREND/BAREND

 ; *********************************************************************

CARDAYS ; EP

 ; Computed field (File 90050.0205, Field .07)

 N I,J,BAREND,CBAREND

 S J=D2

 S BAREND=0

 F I=1:1:3 D  Q:'+J

 . S J=$O(^BARAC(DUZ(2),D0,4,D1,2,J),-1)  ; Previous entry

 . Q:'+J

 . S BAR(0)=$G(^BARAC(DUZ(2),D0,4,D1,2,J,0))

 . S BAREND=$P(BAR(0),U,2)+$P(BAR(0),U,4)-$P(BAR(0),U,5)-$P(BAR(0),U,6)

 I '+J S X="" Q

 S BAREND=BAREND/3

 S BAR(0)=$G(^BARAC(DUZ(2),D0,4,D1,2,D2,0))

 S CBAREND=$P(BAR(0),U,2)+$P(BAR(0),U,4)-$P(BAR(0),U,5)-$P(BAR(0),U,6)

 S X=CBAREND/BAREND

 ; ********************************************************************

WP(BARSTR,BARRAY,BARLNGTH) ; EP ; IHS/DIT/CPC - 20180427 CR5994

 ; Used to read string into array where each line is less than

 ; specified length

 Q:'$D(BARSTR)!'$D(BARRAY)!'$D(BARLNGTH)

 S BARCNT=0

 F  D READ  Q:$L(BARSTR)=0

 K BARSTR,BARLNGTH,BARWORD,BARTXT,BARCNT

 ; ********************************************************************

READ ; ; IHS/DIT/CPC - 20180427 CR5994

 ; Loop through String

 Q:$L(BARSTR)=0                        ; Nothing left in string

 S BARWORD=0

 K BARTXT

 F  D READWORD  Q:$L(BARTXT)>BARLNGTH  Q:$L(BARSTR)=0

 ; ********************************************************************

READWORD ; ; IHS/DIT/CPC - 20180427 CR5994

 ; Loop each "word" of string

 S BARWORD=BARWORD+1

 S BARTXT=$P(BARSTR," ",1,BARWORD)

 I $L(BARTXT)>BARLNGTH D

 .;ADD CODE TO FIND BREAKING CHARACTER IN BARTXT LESS THAN BARLNGTH

 .;FOR NOW ADD A SPACE AT BARLNGTH-1

 .;REPEAT BARTXT SET

 .S BARSTR=$E(BARSTR,1,BARLNGTH-1)_" "_$E(BARSTR,BARLNGTH,)

 .S BARTXT=$P(BARSTR," ",1,BARWORD)

 I $L(BARSTR)=$L(BARTXT) D LASTLINE Q

 I $L(BARTXT)>BARLNGTH D SETLINE

 ; ********************************************************************

SETLINE ;

 S BARCNT=BARCNT+1

 S BARIDR=BARRAY_"("_$J_","_BARCNT_")"

 S @BARIDR=$P(BARSTR," ",1,BARWORD-1)

 S BARSTR=$P(BARSTR," ",BARWORD,9999999999)

 ; ********************************************************************

LASTLINE ;

 S BARCNT=BARCNT+1

 S BARIDR=BARRAY_"("_$J_","_BARCNT_")"

 S @BARIDR=BARSTR

 S BARSTR=""

 ; ********************************************************************

TRANS(BARDUZ,BAR,BARTYPE) ; EP

 ; BARDUZ  = DUZ(2)

 ; BAR     = AR BILL IEN

 ; BARTYPE = TYPE OF TRANSACTION

 ;         = A - Adjustment $

 ;         = C - Copay $

 ;         = P - Paid $

 ;         = D - Deductible $

 I '+$G(BARDUZ) Q 0

 I '+$G(BAR) Q 0

 I $G(BARTYPE)="" Q 0

 K BARAMT

 N BARHOLD,BARTR

 S BARHOLD=DUZ(2)

 I '$D(^BARTR(DUZ(2),"AC",BAR)) Q 0

 S DUZ(2)=BARDUZ

 S BARTR=0

 F  S BARTR=$O(^BARTR(DUZ(2),"AC",BAR,BARTR)) Q:'+BARTR  D TRANS2

 S DUZ(2)=BARHOLD

 I '$D(BARAMT) Q 0

 Q +$G(BARAMT(BARTYPE))

 ; ********************************************************************

TRANS2 ;

 Q:'$D(^BARTR(DUZ(2),BARTR,0))

 S BARAMT("C")=$G(BARAMT("C"))+$$GET1^DIQ(90050.03,BARTR,3.714)

 S BARAMT("D")=$G(BARAMT("D"))+$$GET1^DIQ(90050.03,BARTR,3.713)

 S BARAMT("A")=$G(BARAMT("A"))+$$GET1^DIQ(90050.03,BARTR,3.7)

 I $P($G(^BARTR(DUZ(2),BARTR,1)),U)=40 D

 . S BARAMT("P")=$G(BARAMT("P"))+$$GET1^DIQ(90050.03,BARTR,3.5)

BARDUTL   ; IHS/SD/LSL - DATE UTILITIES FOR A/R PACKAGE ;

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,6,28**;OCT 26, 2005;Build 92

 +2       ;

 +3       ; IHS/SD/LSL - 02/20/04 - V1.7 Patch 5 - REMARK CODES

 +4       ;      New utility to read in string to local array for printing

 +5       ;

 +6       ; IHS/SD/LSL - 03/29/04 - V1.8

 +7       ;      Added TRANS utility to find all $$ for specific trans type

 +8       ;      on a bill.

 +9       ; IHS/DIT/CPC - 20180427 CR9580 - Add Fileman to XML date conversion

 +10      ; IHS/DIT/CPC - 20180427 CR5994 - Add utility to add wrapping break to a string at specified length.

 +11      ;

 +12      ; ********************************************************************

 +13      ;

SDT(X)    ; EP - Y is set to the printable date ##/##/## from X (fileman date)

 +1        NEW Y

 +2       ;Y2000

           SET Y=$SELECT(+X>0:$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_($EXTRACT(X,1,3)+1700),1:"")

 +3        QUIT Y

 +4       ;start new code IHS/SD/SDR bar*1.8*6 4.1.3

 +5       ; *********************************************************************

SHDT(X)   ; EP - Y is set to the printable date ##/##/## from X (fileman date)

 +1        NEW Y

 +2       ;Y2000

           SET Y=$SELECT(+X>0:$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3),1:"")

 +3        QUIT Y

 +4       ;end new code bar*1.8*6

 +5       ; *********************************************************************

 +6       ;

HDT(X)    ;EP - Y is set to the printable date ##-##-## from X (fileman date)

 +1        NEW Y

 +2       ;Y2000

           SET Y=$SELECT(+X>0:$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_($EXTRACT(X,1,3)+1700),1:"")

 +3        QUIT Y

 +4       ; *********************************************************************

 +5       ;

CDT(X)    ;EP - Y= date/time ##/##/##@##:## from X (fm date) for display in claim editor

 +1        NEW Y

 +2        IF '+X

               SET Y=""

               QUIT Y

 +3       ;Y2000

           SET Y=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_($EXTRACT(X,1,3)+1700)

 +4        IF '$PIECE(X,".",2)

               QUIT Y

 +5        SET BARTIME=$PIECE(X,".",2)

 +6        SET BARTIME=BARTIME_"00"

 +7        SET Y=Y_"@"_$EXTRACT(BARTIME,1,2)_":"_$EXTRACT(BARTIME,3,4)

 +8        QUIT Y

 +9       ; *********************************************************************

 +10      ;

 +11      ;Start new code IHS/DIT/CPC BAR*1.8*28 CR8345 HEAT224215

XDT(X)    ;EP - Y=XML date/time CCYYMMDDTHH:MM:SS.MSS

 +1        NEW Y

 +2        IF '+X

               SET Y=""

               QUIT Y

 +3        SET Y=($EXTRACT(X,1,3)+1700)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"T"

 +4        IF '$PIECE(X,".",2)

               QUIT Y_"00:00:00.000"

 +5        SET BARTIME=$PIECE(X,".",2)

 +6        SET BARTIME=BARTIME_"000000"

 +7        SET Y=Y_$EXTRACT(BARTIME,1,2)_":"_$EXTRACT(BARTIME,3,4)_":"_$EXTRACT(BARTIME,5,6)_".000"

 +8        QUIT Y

 +9       ; *********************************************************************

 +10      ;

 +11      ;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.4

 +12      ;

TDT(X)    ;EP - Y= date/time ##/##/##@##:##:## from X (fm date) for display of formatted trans date

 +1        NEW Y

 +2        IF '+X

               SET Y=""

               QUIT Y

 +3        SET Y=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_($EXTRACT(X,1,3)+1700)

 +4        IF '$PIECE(X,".",2)

               QUIT Y

 +5        SET BARTIME=$PIECE(X,".",2)

 +6        SET BARTIME=BARTIME_"00"

 +7        SET Y=Y_"@"_$EXTRACT(BARTIME,1,2)_":"_$EXTRACT(BARTIME,3,4)_":"_$EXTRACT(BARTIME,5,6)

 +8        QUIT Y

 +9       ; *********************************************************************

 +10      ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.4

 +11      ;

MDT(X)    ;EP - printable date and time in menu header format

 +1       ;Y2000

           SET BAR("DATE")=+$EXTRACT(X,6,7)_"-"_$PIECE($TEXT(MTHS+1),";;",+$EXTRACT(X,4,5)+1)_"-"_($EXTRACT(X,1,3)+1700)

 +2        SET BAR("TIME")=$PIECE(X,".",2)

 +3        IF BAR("TIME")'=""

               Begin DoDot:1

 +4                SET BAR("TIME")="."_BAR("TIME")

 +5                SET BAR("TIME")=$EXTRACT(X,8,15)+.0000001

 +6                SET BAR("AMPM")=$SELECT(BAR("TIME")>.1159999:"PM",1:"AM")

 +7                IF BAR("TIME")>.1259999

                       SET BAR("TIME")=BAR("TIME")-.12

 +8                SET BAR("TIME")=+$EXTRACT(BAR("TIME"),2,3)_":"_$EXTRACT(BAR("TIME"),4,5)_" "_BAR("AMPM")

 +9                SET BAR("TIME")=" "_BAR("TIME")

               End DoDot:1

 +10       SET X=BAR("DATE")_BAR("TIME")

 +11       KILL BAR("DATE"),BAR("TIME"),BAR("AMPM")

 +12       QUIT X

 +13      ; *********************************************************************

 +14      ;

MDT2(X)   ;EP - printable date, letter format

 +1       ;Y2000

           SET X=+$EXTRACT(X,6,7)_" "_$PIECE($TEXT(MTHS+1),";;",+$EXTRACT(X,4,5)+1)_" "_($EXTRACT(X,1,3)+1700)

 +2        QUIT X

 +3       ; *********************************************************************

 +4       ;

Y2KDT(X)  ;EP - date from fileman to Y2K format Y=MMDDCCYY

 +1        NEW Y

 +2        IF X=""

               QUIT X

 +3        SET Y=$EXTRACT(X,4,7)_($EXTRACT(X,1,3)+1700)

 +4        QUIT Y

 +5       ; *********************************************************************

Y2KD2(X)  ;EP - date from fileman to Y2K format Y=CCYYMMDD

 +1        NEW Y

 +2        IF X=""

               QUIT X

 +3        SET Y=($EXTRACT(X,1,3)+1700)_$EXTRACT(X,4,7)

 +4        QUIT Y

 +5       ; *********************************************************************

 +6       ;

MTHS      ;MONTHS

 +1       ;;JAN;;FEB;;MAR;;APR;;MAY;;JUN;;JUL;;AUG;;SEP;;OCT;;NOV;;DEC

 +2       ; *********************************************************************

 +3       ;

HRN(X)    ;EP - Y is set to the printable HRN

 +1       ;     for patient BARP("PDFN") at location BARP("LDFN")

 +2        SET Y=$SELECT('$GET(BARP("PDFN")):"[no PAT]",'$GET(BARP("LDFN")):"[no LOC]",$DATA(^AUPNPAT(BARP("PDFN"),41,BARP("LDFN"),0)):"[HRN:"_$PIECE(^(0),U,2)_"]",1:"[no HRN]")

 +3        QUIT Y

 +4       ; *********************************************************************

 +5       ;

CSZ(X)    ;EP - Y is set to the printable City, State ZIP CODE

 +1       ; X incoming variable must = CITY^ST^ZIP

 +2        SET Y=$SELECT($GET(X)="":"no address",$PIECE(X,U)="":"no city",'$PIECE(X,U,2):"no state",$PIECE($GET(^DIC(5,$PIECE(X,U,2),0)),U,2)="":"invalid state",'$PIECE(X,U,3):"no zip",1:$PIECE(X,U)_", "_$PIECE(^(0),U,2)_"  "_$PIECE(X,U,3))

 +3        QUIT Y

 +4       ; *********************************************************************

 +5       ;

TM(X,Y)   ;EP - FIGURE TOTAL MINUTES GIVEN FM DATE/TIMES IN X AND Y

 +1        IF X=""

               QUIT X

 +2        IF Y=""

               SET X=""

               QUIT X

 +3        DO H^%DTC

 +4        SET BAR(1,1)=%H

 +5        SET BAR(1,2)=%T

 +6        SET X=Y

 +7        DO H^%DTC

 +8        SET BAR(2,1)=%H

 +9        SET BAR(2,2)=%T

 +10       SET BAR("D")=BAR(2,1)-BAR(1,1)*24*60*60

 +11       SET BAR("T")=BAR(2,2)-BAR(1,2)

 +12       SET BAR("TS")=BAR("D")+BAR("T")

 +13       SET X=BAR("TS")\60

 +14       QUIT X

 +15      ; *********************************************************************

 +16      ;

PAT(X)    ;EP - DISPLAY PATIENT HEADER WITH IDENTIFIERS - X=DFN

 +1        SET $PIECE(BAR("="),"=",80)=""

 +2        WRITE $$EN^BARVDF("IOF")

 +3        WRITE !,$$EN^BARVDF("RVN"),"PATIENT:",$$EN^BARVDF("RVF"),"  "

 +4        SET BAR("P0")=^DPT(X,0)

 +5        WRITE $PIECE(BAR("P0"),"^",1),"     ",$PIECE(BAR("P0"),"^",2)

 +6        SET BAR("DOB")=$PIECE(BAR("P0"),"^",3)

 +7       ;Y2000

           WRITE "  ",$EXTRACT(BAR("DOB"),4,5),"/",$EXTRACT(BAR("DOB"),6,7),"/",($EXTRACT(BAR("DOB"),1,3)+1700)

 +8        SET BAR("SSN")=$PIECE(BAR("P0"),"^",9)

 +9        WRITE "  ",$EXTRACT(BAR("SSN"),1,3),"-",$EXTRACT(BAR("SSN"),4,5),"-",$EXTRACT(BAR("SSN"),6,9)

 +10       WRITE "  ","HRN: ",$PIECE($GET(^AUPNPAT(X,41,DUZ(2),0)),"^",2)

 +11       WRITE !,BAR("=")

 +12       QUIT

 +13      ; *********************************************************************

 +14      ;

DATE(X)   ;EP - ask beginning and ending date

 +1        SET %DT="AEP"

 +2        SET %DT("A")="Select "_$PIECE("Beginning^Ending","^",X)_" Date: "

 +3        DO ^%DT

 +4        QUIT Y

 +5       ; *********************************************************************

 +6       ;

MSG(DATA,PRE,POST,BEEP) ;EP; Writes line to device

 +1        NEW X,Y

 +2        IF PRE>0

               FOR I=1:1:PRE

                   WRITE !

 +3        WRITE DATA

 +4        IF POST>0

               FOR I=1:1:POST

                   WRITE !

 +5        IF $GET(BEEP)>0

               FOR I=1:1:BEEP

                   WRITE $CHAR(7)

 +6        QUIT

 +7       ; *********************************************************************

 +8       ;

ARDAYS    ; EP

 +1       ; Computed field (File 90050.0204, Field .07)

 +2        NEW I,J,BAREND,CBAREND

 +3        SET J=D1

 +4        SET BAREND=0

 +5        FOR I=1:1:3

               Begin DoDot:1

 +6       ; Previous entry

                   SET J=$ORDER(^BARAC(DUZ(2),D0,4,J),-1)

 +7                IF '+J

                       QUIT

 +8                SET BAR(0)=$GET(^BARAC(DUZ(2),D0,4,J,0))

 +9                SET BARTMP=$PIECE(BAR(0),U,2)+$PIECE(BAR(0),U,4)-$PIECE(BAR(0),U,5)-$PIECE(BAR(0),U,6)

 +10               SET BAREND=BAREND+BARTMP

               End DoDot:1

               IF '+J

                   QUIT

 +11       IF '+J

               SET X=""

               QUIT

 +12       SET BAREND=BAREND/3

 +13       SET BAR(0)=$GET(^BARAC(DUZ(2),D0,4,D1,0))

 +14       SET CBAREND=$PIECE(BAR(0),U,2)+$PIECE(BAR(0),U,4)-$PIECE(BAR(0),U,5)-$PIECE(BAR(0),U,6)

 +15       SET X=CBAREND/BAREND

 +16       QUIT

 +17      ; *********************************************************************

 +18      ;

VARDAYS   ; EP

 +1       ; Computed field (File 90050.0205, Field .07)

 +2        NEW I,J,BAREND,CBAREND

 +3        SET J=D2

 +4        SET BAREND=0

 +5        FOR I=1:1:3

               Begin DoDot:1

 +6       ; Previous entry

                   SET J=$ORDER(^BARAC(DUZ(2),D0,4,D1,1,J),-1)

 +7                IF '+J

                       QUIT

 +8                SET BAR(0)=$GET(^BARAC(DUZ(2),D0,4,D1,1,J,0))

 +9                SET BAREND=$PIECE(BAR(0),U,2)+$PIECE(BAR(0),U,4)-$PIECE(BAR(0),U,5)-$PIECE(BAR(0),U,6)

               End DoDot:1

               IF '+J

                   QUIT

 +10       IF '+J

               SET X=""

               QUIT

 +11       SET BAREND=BAREND/3

 +12       SET BAR(0)=$GET(^BARAC(DUZ(2),D0,4,D1,1,D2,0))

 +13       SET CBAREND=$PIECE(BAR(0),U,2)+$PIECE(BAR(0),U,4)-$PIECE(BAR(0),U,5)-$PIECE(BAR(0),U,6)

 +14       SET X=CBAREND/BAREND

 +15       QUIT

 +16      ; *********************************************************************

 +17      ;

CARDAYS   ; EP

 +1       ; Computed field (File 90050.0205, Field .07)

 +2        NEW I,J,BAREND,CBAREND

 +3        SET J=D2

 +4        SET BAREND=0

 +5        FOR I=1:1:3

               Begin DoDot:1

 +6       ; Previous entry

                   SET J=$ORDER(^BARAC(DUZ(2),D0,4,D1,2,J),-1)

 +7                IF '+J

                       QUIT

 +8                SET BAR(0)=$GET(^BARAC(DUZ(2),D0,4,D1,2,J,0))

 +9                SET BAREND=$PIECE(BAR(0),U,2)+$PIECE(BAR(0),U,4)-$PIECE(BAR(0),U,5)-$PIECE(BAR(0),U,6)

               End DoDot:1

               IF '+J

                   QUIT

 +10       IF '+J

               SET X=""

               QUIT

 +11       SET BAREND=BAREND/3

 +12       SET BAR(0)=$GET(^BARAC(DUZ(2),D0,4,D1,2,D2,0))

 +13       SET CBAREND=$PIECE(BAR(0),U,2)+$PIECE(BAR(0),U,4)-$PIECE(BAR(0),U,5)-$PIECE(BAR(0),U,6)

 +14       SET X=CBAREND/BAREND

 +15       QUIT

 +16      ;

 +17      ; ********************************************************************

WP(BARSTR,BARRAY,BARLNGTH) ; EP ; IHS/DIT/CPC - 20180427 CR5994

 +1       ; Used to read string into array where each line is less than

 +2       ; specified length

 +3        IF '$DATA(BARSTR)!'$DATA(BARRAY)!'$DATA(BARLNGTH)

               QUIT

 +4        SET BARCNT=0

 +5        FOR

               DO READ

               IF $LENGTH(BARSTR)=0

                   QUIT

 +6        KILL BARSTR,BARLNGTH,BARWORD,BARTXT,BARCNT

 +7        QUIT

 +8       ; ********************************************************************

 +9       ;

READ      ; ; IHS/DIT/CPC - 20180427 CR5994

 +1       ; Loop through String

 +2       ; Nothing left in string

           IF $LENGTH(BARSTR)=0

               QUIT

 +3        SET BARWORD=0

 +4        KILL BARTXT

 +5        FOR

               DO READWORD

               IF $LENGTH(BARTXT)>BARLNGTH

                   QUIT

               IF $LENGTH(BARSTR)=0

                   QUIT

 +6        QUIT

 +7       ; ********************************************************************

 +8       ;

READWORD  ; ; IHS/DIT/CPC - 20180427 CR5994

 +1       ; Loop each "word" of string

 +2        SET BARWORD=BARWORD+1

 +3        SET BARTXT=$PIECE(BARSTR," ",1,BARWORD)

 +4        IF $LENGTH(BARTXT)>BARLNGTH

               Begin DoDot:1

 +5       ;ADD CODE TO FIND BREAKING CHARACTER IN BARTXT LESS THAN BARLNGTH

 +6       ;FOR NOW ADD A SPACE AT BARLNGTH-1

 +7       ;REPEAT BARTXT SET

 +8                SET BARSTR=$EXTRACT(BARSTR,1,BARLNGTH-1)_" "_$EXTRACT(BARSTR,BARLNGTH,)

 +9                SET BARTXT=$PIECE(BARSTR," ",1,BARWORD)

               End DoDot:1

 +10       IF $LENGTH(BARSTR)=$LENGTH(BARTXT)

               DO LASTLINE

               QUIT

 +11       IF $LENGTH(BARTXT)>BARLNGTH

               DO SETLINE

 +12       QUIT

 +13      ; ********************************************************************

 +14      ;

SETLINE   ;

 +1        SET BARCNT=BARCNT+1

 +2        SET BARIDR=BARRAY_"("_$JOB_","_BARCNT_")"

 +3        SET @BARIDR=$PIECE(BARSTR," ",1,BARWORD-1)

 +4        SET BARSTR=$PIECE(BARSTR," ",BARWORD,9999999999)

 +5        QUIT

 +6       ; ********************************************************************

 +7       ;

LASTLINE  ;

 +1        SET BARCNT=BARCNT+1

 +2        SET BARIDR=BARRAY_"("_$JOB_","_BARCNT_")"

 +3        SET @BARIDR=BARSTR

 +4        SET BARSTR=""

 +5        QUIT

 +6       ; ********************************************************************

 +7       ;

TRANS(BARDUZ,BAR,BARTYPE) ; EP

 +1       ; BARDUZ  = DUZ(2)

 +2       ; BAR     = AR BILL IEN

 +3       ; BARTYPE = TYPE OF TRANSACTION

 +4       ;         = A - Adjustment $

 +5       ;         = C - Copay $

 +6       ;         = P - Paid $

 +7       ;         = D - Deductible $

 +8        IF '+$GET(BARDUZ)

               QUIT 0

 +9        IF '+$GET(BAR)

               QUIT 0

 +10       IF $GET(BARTYPE)=""

               QUIT 0

 +11       KILL BARAMT

 +12       NEW BARHOLD,BARTR

 +13       SET BARHOLD=DUZ(2)

 +14       IF '$DATA(^BARTR(DUZ(2),"AC",BAR))

               QUIT 0

 +15       SET DUZ(2)=BARDUZ

 +16       SET BARTR=0

 +17       FOR

               SET BARTR=$ORDER(^BARTR(DUZ(2),"AC",BAR,BARTR))

               IF '+BARTR

                   QUIT

               DO TRANS2

 +18       SET DUZ(2)=BARHOLD

 +19       IF '$DATA(BARAMT)

               QUIT 0

 +20       QUIT +$GET(BARAMT(BARTYPE))

 +21      ; ********************************************************************

 +22      ;

TRANS2    ;

 +1        IF '$DATA(^BARTR(DUZ(2),BARTR,0))

               QUIT

 +2        SET BARAMT("C")=$GET(BARAMT("C"))+$$GET1^DIQ(90050.03,BARTR,3.714)

 +3        SET BARAMT("D")=$GET(BARAMT("D"))+$$GET1^DIQ(90050.03,BARTR,3.713)

 +4        SET BARAMT("A")=$GET(BARAMT("A"))+$$GET1^DIQ(90050.03,BARTR,3.7)

 +5        IF $PIECE($GET(^BARTR(DUZ(2),BARTR,1)),U)=40

               Begin DoDot:1

 +6                SET BARAMT("P")=$GET(BARAMT("P"))+$$GET1^DIQ(90050.03,BARTR,3.5)

               End DoDot:1

 +7        QUIT

BARDUTL.m