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("=")
Q
; *********************************************************************
;
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)
Q
; *********************************************************************
;
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
Q
; *********************************************************************
;
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
Q
; *********************************************************************
;
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
Q
;
; ********************************************************************
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
Q
; ********************************************************************
;
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
Q
; ********************************************************************
;
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
Q
; ********************************************************************
;
SETLINE ;
S BARCNT=BARCNT+1
S BARIDR=BARRAY_"("_$J_","_BARCNT_")"
S @BARIDR=$P(BARSTR," ",1,BARWORD-1)
S BARSTR=$P(BARSTR," ",BARWORD,9999999999)
Q
; ********************************************************************
;
LASTLINE ;
S BARCNT=BARCNT+1
S BARIDR=BARRAY_"("_$J_","_BARCNT_")"
S @BARIDR=BARSTR
S BARSTR=""
Q
; ********************************************************************
;
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)
Q
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
