BCHEXD2 ; IHS/CMI/LAB -PROCESS RECORD ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;IHS/CMI/LAB - added $J to ^TMP
;
;Create export record. 68 characters in length.
;
RECORD ;EP
S (BCHE,BCHTX)=""
D ^BCHEXD21 ;IHS/CMI/LAB - new export format
Q ;IHS/CMI/LAB - new export
PROV ;get providers (1-4)
I $P(BCHREC,U,3)="" S BCHE="E022" Q
S BCHAFF=$$PPAFFL^BCHUTIL(BCHR,"I") I BCHAFF=""!(BCHAFF["?") S BCHE="E023" Q
S BCHDISC=$$PPCLSC^BCHUTIL(BCHR) I BCHDISC=""!(BCHDISC["?") S BCHE="E024" Q
S BCHINI=$$PPINI^BCHUTIL(BCHR) I BCHINI["?" S BCHE="E025" Q
PROV1 S X=BCHAFF_BCHDISC_BCHINI
S X=$$LBLK(X,6)
D TX
PROG ;
S X=$P(BCHREC,U,2) I X]"" S X=$P(^BCHTPROG(X,0),U,5)
I X="" S X="-1"
S X=$$LBLK(X,7)
D TX
DATE ;
S X=$P($P(BCHREC,U),".")
D TX
FORM ;
S X=$P(BCHREC,U,25),X=$$LZERO(X,3) D TX
ARN S X=BCHCPOV,X=$$LZERO(X,2) D TX
RH S X=$P(BCHREC,U,26) S:X="" X="-" D TX
S X=" " D TX
SC ;
S P=$P(^BCHRPROB(BCHPOVD,0),U,4),X=$S(P]"":$P(^BCHTSERV(P,0),U,3),1:" -")
S:X="" X=" -"
D TX
S X=" " D TX
POV ;
S X=$P(^BCHRPROB(BCHPOVD,0),U),X=$P(^BCHTPROB(X,0),U,2)
S:X="" X="-1"
S:X="-" X=" -"
D TX
S X=" " D TX
ACTL ;
S X=$P(BCHREC,U,6),X=$S(X]"":$P(^BCHTACTL(X,0),U,5),1:" -") S:X="-" X=" -" S:X="" X=" -" S:X="--" X=" -"
D TX
NS ;
S X=$P(BCHREC,U,12) S:'X X=0 S X=$$LZERO(X,4)
D TX
ST ;
S X=$P(^BCHRPROB(BCHPOVD,0),U,5) S:'X X=1 S X=$$LZERO(X,4)
D TX
TT ;
I BCHCPOV=1 S X=$P(BCHREC,U,11) S:'X X=0 S X=$$LZERO(X,4)
E S X=" 0"
D TX
S X=" " D TX
AGE ;
S X2=$P($G(^BCHR(BCHR,11)),U,2)
I X2]"" D I 1
.S X1=$P($P(BCHREC,U),".") D ^%DTC S BCHAGE=X,BCHAGE=$J(BCHAGE/365.25,3,0) S X=$$LZERO(BCHAGE,3)
E S X=" ",X=$$LBLK(X,3)
D TX
S X=" " D TX
SEX ;
S X=$S($P($G(^BCHR(BCHR,11)),U,3)]"":$P($G(^BCHR(BCHR,11)),U,3),1:" ")
S X=$$LBLK(X,2)
D TX
S X=" " D TX
REFF ;
S X="" I BCHCPOV=1 S X=$P(BCHREC,U,7) S:X'="" X=$P(^BCHTREF(X,0),U,3)
S:X="" X=" "
D TX
S X=" " D TX
REFT ;
S X="" I BCHCPOV=1 S X=$P(BCHREC,U,8) S:X'="" X=$P(^BCHTREF(X,0),U,3)
S:X="" X=" "
D TX
S X=" " D TX
SUB ;
S X=$P(^BCHRPROB(BCHPOVD,0),U,7)
S:X="" X=" "
D TX
S X=" " D TX
EVAL ;
S X="" I BCHCPOV=1 S X=$P(BCHREC,U,9)
S:X="" X=" "
D TX
S X=" " D TX
TYPE ;
S X="U"
D TX
Q
TX ;EP
S BCHTX=BCHTX_X
Q
;
LZERO(V,L) ;EP - left zero fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
Q V
LBLK(V,L) ;EP - left blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
Q V
RBLK(V,L) ;right blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=V_" "
Q V
DELETES ;EP - called from BCHEXD , send delete txs
Q ;IHS/CMI/LAB - new format
S BCH("CONTROL DATE")=BCH("RUN BEGIN")-1
F S BCH("CONTROL DATE")=$O(^BCHEXDEL("AEX",BCH("CONTROL DATE"))) Q:BCH("CONTROL DATE")=""!(BCH("CONTROL DATE")>BCH("RUN END")) D DELETES2 Q:BCH("QFLG")
Q
DELETES2 ;
S BCHR="" F S BCHR=$O(^BCHEXDEL("AEX",BCH("CONTROL DATE"),BCHR)) Q:BCHR="" D DELETES3 Q:BCH("QFLG")
Q
DELETES3 ;
S BCHTX=""
S BCHV("TX GENERATED")=0,^TMP("BCHDR",$J,"DELETES",BCH("CONTROL DATE"),BCHR)=BCH("MAIN TX DATE")
X BCHCNT
S X=$P(^BCHEXDEL(BCHR,0),U),X=$$LBLK(X,6) D TX
S X=$P(^BCHEXDEL(BCHR,0),U,2) S X=$$LBLK(X,7) D TX
S X=$P(^BCHEXDEL(BCHR,0),U,3) S X=$$LBLK(X,7) D TX
S X=$P(^BCHEXDEL(BCHR,0),U,4) S X=$$LZERO(X,3) D TX
S $E(BCHTX,68)=BCHRTYPE
D CNTBUILD^BCHEXD
K ^BCHEXDEL("AEX",BCH("CONTROL DATE"),BCHR)
Q
;
BCHEXD2 ; IHS/CMI/LAB -PROCESS RECORD ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;IHS/CMI/LAB - added $J to ^TMP
+3 ;
+4 ;Create export record. 68 characters in length.
+5 ;
RECORD ;EP
+1 SET (BCHE,BCHTX)=""
+2 ;IHS/CMI/LAB - new export format
DO ^BCHEXD21
+3 ;IHS/CMI/LAB - new export
QUIT
PROV ;get providers (1-4)
+1 IF $PIECE(BCHREC,U,3)=""
SET BCHE="E022"
QUIT
+2 SET BCHAFF=$$PPAFFL^BCHUTIL(BCHR,"I")
IF BCHAFF=""!(BCHAFF["?")
SET BCHE="E023"
QUIT
+3 SET BCHDISC=$$PPCLSC^BCHUTIL(BCHR)
IF BCHDISC=""!(BCHDISC["?")
SET BCHE="E024"
QUIT
+4 SET BCHINI=$$PPINI^BCHUTIL(BCHR)
IF BCHINI["?"
SET BCHE="E025"
QUIT
PROV1 SET X=BCHAFF_BCHDISC_BCHINI
+1 SET X=$$LBLK(X,6)
+2 DO TX
PROG ;
+1 SET X=$PIECE(BCHREC,U,2)
IF X]""
SET X=$PIECE(^BCHTPROG(X,0),U,5)
+2 IF X=""
SET X="-1"
+3 SET X=$$LBLK(X,7)
+4 DO TX
DATE ;
+1 SET X=$PIECE($PIECE(BCHREC,U),".")
+2 DO TX
FORM ;
+1 SET X=$PIECE(BCHREC,U,25)
SET X=$$LZERO(X,3)
DO TX
ARN SET X=BCHCPOV
SET X=$$LZERO(X,2)
DO TX
RH SET X=$PIECE(BCHREC,U,26)
IF X=""
SET X="-"
DO TX
+1 SET X=" "
DO TX
SC ;
+1 SET P=$PIECE(^BCHRPROB(BCHPOVD,0),U,4)
SET X=$SELECT(P]"":$PIECE(^BCHTSERV(P,0),U,3),1:" -")
+2 IF X=""
SET X=" -"
+3 DO TX
+4 SET X=" "
DO TX
POV ;
+1 SET X=$PIECE(^BCHRPROB(BCHPOVD,0),U)
SET X=$PIECE(^BCHTPROB(X,0),U,2)
+2 IF X=""
SET X="-1"
+3 IF X="-"
SET X=" -"
+4 DO TX
+5 SET X=" "
DO TX
ACTL ;
+1 SET X=$PIECE(BCHREC,U,6)
SET X=$SELECT(X]"":$PIECE(^BCHTACTL(X,0),U,5),1:" -")
IF X="-"
SET X=" -"
IF X=""
SET X=" -"
IF X="--"
SET X=" -"
+2 DO TX
NS ;
+1 SET X=$PIECE(BCHREC,U,12)
IF 'X
SET X=0
SET X=$$LZERO(X,4)
+2 DO TX
ST ;
+1 SET X=$PIECE(^BCHRPROB(BCHPOVD,0),U,5)
IF 'X
SET X=1
SET X=$$LZERO(X,4)
+2 DO TX
TT ;
+1 IF BCHCPOV=1
SET X=$PIECE(BCHREC,U,11)
IF 'X
SET X=0
SET X=$$LZERO(X,4)
+2 IF '$TEST
SET X=" 0"
+3 DO TX
+4 SET X=" "
DO TX
AGE ;
+1 SET X2=$PIECE($GET(^BCHR(BCHR,11)),U,2)
+2 IF X2]""
Begin DoDot:1
+3 SET X1=$PIECE($PIECE(BCHREC,U),".")
DO ^%DTC
SET BCHAGE=X
SET BCHAGE=$JUSTIFY(BCHAGE/365.25,3,0)
SET X=$$LZERO(BCHAGE,3)
End DoDot:1
IF 1
+4 IF '$TEST
SET X=" "
SET X=$$LBLK(X,3)
+5 DO TX
+6 SET X=" "
DO TX
SEX ;
+1 SET X=$SELECT($PIECE($GET(^BCHR(BCHR,11)),U,3)]"":$PIECE($GET(^BCHR(BCHR,11)),U,3),1:" ")
+2 SET X=$$LBLK(X,2)
+3 DO TX
+4 SET X=" "
DO TX
REFF ;
+1 SET X=""
IF BCHCPOV=1
SET X=$PIECE(BCHREC,U,7)
IF X'=""
SET X=$PIECE(^BCHTREF(X,0),U,3)
+2 IF X=""
SET X=" "
+3 DO TX
+4 SET X=" "
DO TX
REFT ;
+1 SET X=""
IF BCHCPOV=1
SET X=$PIECE(BCHREC,U,8)
IF X'=""
SET X=$PIECE(^BCHTREF(X,0),U,3)
+2 IF X=""
SET X=" "
+3 DO TX
+4 SET X=" "
DO TX
SUB ;
+1 SET X=$PIECE(^BCHRPROB(BCHPOVD,0),U,7)
+2 IF X=""
SET X=" "
+3 DO TX
+4 SET X=" "
DO TX
EVAL ;
+1 SET X=""
IF BCHCPOV=1
SET X=$PIECE(BCHREC,U,9)
+2 IF X=""
SET X=" "
+3 DO TX
+4 SET X=" "
DO TX
TYPE ;
+1 SET X="U"
+2 DO TX
+3 QUIT
TX ;EP
+1 SET BCHTX=BCHTX_X
+2 QUIT
+3 ;
LZERO(V,L) ;EP - left zero fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V="0"_V
+3 QUIT V
LBLK(V,L) ;EP - left blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=" "_V
+3 QUIT V
RBLK(V,L) ;right blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=V_" "
+3 QUIT V
DELETES ;EP - called from BCHEXD , send delete txs
+1 ;IHS/CMI/LAB - new format
QUIT
+2 SET BCH("CONTROL DATE")=BCH("RUN BEGIN")-1
+3 FOR
SET BCH("CONTROL DATE")=$ORDER(^BCHEXDEL("AEX",BCH("CONTROL DATE")))
IF BCH("CONTROL DATE")=""!(BCH("CONTROL DATE")>BCH("RUN END"))
QUIT
DO DELETES2
IF BCH("QFLG")
QUIT
+4 QUIT
DELETES2 ;
+1 SET BCHR=""
FOR
SET BCHR=$ORDER(^BCHEXDEL("AEX",BCH("CONTROL DATE"),BCHR))
IF BCHR=""
QUIT
DO DELETES3
IF BCH("QFLG")
QUIT
+2 QUIT
DELETES3 ;
+1 SET BCHTX=""
+2 SET BCHV("TX GENERATED")=0
SET ^TMP("BCHDR",$JOB,"DELETES",BCH("CONTROL DATE"),BCHR)=BCH("MAIN TX DATE")
+3 XECUTE BCHCNT
+4 SET X=$PIECE(^BCHEXDEL(BCHR,0),U)
SET X=$$LBLK(X,6)
DO TX
+5 SET X=$PIECE(^BCHEXDEL(BCHR,0),U,2)
SET X=$$LBLK(X,7)
DO TX
+6 SET X=$PIECE(^BCHEXDEL(BCHR,0),U,3)
SET X=$$LBLK(X,7)
DO TX
+7 SET X=$PIECE(^BCHEXDEL(BCHR,0),U,4)
SET X=$$LZERO(X,3)
DO TX
+8 SET $EXTRACT(BCHTX,68)=BCHRTYPE
+9 DO CNTBUILD^BCHEXD
+10 KILL ^BCHEXDEL("AEX",BCH("CONTROL DATE"),BCHR)
+11 QUIT
+12 ;
