BCHEXD ; IHS/CMI/LAB - MAIN DRIVER FOR CHR EXPORT TX GEN ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;IHS/CMI/LAB - PATCH 10 NEW RECORD FORMAT
;IHS/CMI/LAB ;added $J to ^TMP
;
;Main driver routine for the generation of transactions to be
;exported to the CHR System.
;
START ;
I $D(ZTQUEUED) S BCHO("SCHEDULED")=""
S BCHO("RUN")="NEW" ; Let BCHEXDI know this is a new run.
D ^BCHEXDI ; Do initialization
I $D(BCHO("QUEUE")) D EOJ W !!,"Okay, your request is queued! Bye",! Q
I BCH("QFLG")=99 D EOJ W !!,"Bye",!! Q
I BCH("QFLG") D ABORT Q
DRIVER ;called from TSKMN+2
S BCH("BT")=$H
D NOW^%DTC S BCH("RUN START")=%,BCH("MAIN TX DATE")=$P(%,".") K %,%H,%I
S DIE="^BCHXLOG(",DA=BCH("RUN LOG"),DR=".15///R"_";.03////"_BCH("RUN START") D CALLDIE^BCHUTIL
I $D(Y) D ABORT Q
S BCHCNT=$S('$D(ZTQUEUED):"X BCHCNT1 X BCHCNT2",1:"S BCHCNTR=BCHCNTR+1"),BCHCNT1="F BCHCNTL=1:1:$L(BCHCNTR)+1 W @BCHBS",BCHCNT2="S BCHCNTR=BCHCNTR+1 W BCHCNTR,"")"""
D PROCESS ; Generate trasactions
I BCH("QFLG") D ABORT Q
D ^BCHEXLOG ; Update Log
I BCH("QFLG") D ABORT Q
D PURGE ; Purge AEX xref entries
D RUNTIME^BCHEXEOJ ; Show run time
D TAPE ; Write transactions to tape
I BCH("QFLG") D ABORT Q
D:'$D(ZTQUEUED) CHKLOG ; See if Log needs cleaning
I '$D(ZTQUEUED) W !! S DIR(0)="E",DIR("A")="DONE -- Press RETURN to Continue" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
D EOJ
Q
;
PROCESS ;
;build header record
;S BCH("COUNT")=BCH("COUNT")+1
W:'$D(ZTQUEUED) !,"Generating transactions. Counting records. (1)"
S BCHCNTR=0,BCH("CONTROL DATE")=BCH("RUN BEGIN")-1,BCH("POSTING DATE")=" "
S BCHRTYPE="U"
F S BCH("CONTROL DATE")=$O(^BCHR("AEX",BCH("CONTROL DATE"))) Q:BCH("CONTROL DATE")=""!(BCH("CONTROL DATE")>BCH("RUN END")) D PROCESS2 Q:BCH("QFLG")
S BCHRTYPE="D" D DELETES ;gather up and send deletes
Q
PROCESS2 ;
S BCHR="" F S BCHR=$O(^BCHR("AEX",BCH("CONTROL DATE"),BCHR)) Q:BCHR="" D PROCESS3 Q:BCH("QFLG")
Q
PROCESS3 ;
I '$D(^BCHR(BCHR,0)) K ^BCHR("AEX",BCH("CONTROL DATE"),BCHR) Q ;IHS/CMI/LAB - missing record
K BCHE,BCHCPOV
Q:$D(^BCHXLOG(BCH("RUN LOG"),21,BCHR))
S BCHV("TX GENERATED")=0,^TMP("BCHDR",$J,BCH("CONTROL DATE"),BCHR)="",^TMP("BCHDR",$J,"MAIN TX",BCHR)=""
S BCH("VISIT COUNT")=BCH("VISIT COUNT")+1
X BCHCNT
I '$D(^BCHRPROB("AD",BCHR)) S BCHE="E021" D CNTBUILD Q
S BCHREC=^BCHR(BCHR,0)
K BCHE,BCHTX S (BCHCPOV,BCHPOVD)=0 F S BCHPOVD=$O(^BCHRPROB("AD",BCHR,BCHPOVD)) Q:BCHPOVD'=+BCHPOVD D
.I $P(^BCHRPROB(BCHPOVD,0),U,4)=""!($P(^BCHRPROB(BCHPOVD,0),U,5)="")!($P(^BCHRPROB(BCHPOVD,0),U,6)="") S BCHE="E021" Q
.;D RECORD^BCHEXD2
.;D CNTBUILD
I $D(BCHE) D CNTBUILD Q ;IHS/CMI/LAB - new format
D ^XBFMK
K BCHE,BCHTX,BCH("POVS")
D RECORD^BCHEXD2
D CNTBUILD
S DA=BCH("RUN LOG"),DR="2101///""`"_BCHR_"""",DIE="^BCHXLOG("
S DR(2,90002.912101)=".02////"_BCHV("TX GENERATED")_";.03///"_BCHRTYPE
D CALLDIE^BCHUTIL
Q
;
PURGE ; PURGE 'AEX' XREF FOR CHR RECORDS JUST DONE
W:'$D(ZTQUEUED) !,"Deleting cross-reference entries. (1)"
S BCHCNTR=0,BCHV("R DATE")=""
F S BCHV("R DATE")=$O(^TMP("BCHDR",$J,BCHV("R DATE"))) Q:BCHV("R DATE")'=+BCHV("R DATE") D PURGE2
DEL ;update delete file
S BCHV("R DATE")=""
F S BCHV("R DATE")=$O(^TMP("BCHDR",$J,"DELETES",BCHV("R DATE"))) Q:BCHV("R DATE")'=+BCHV("R DATE") D
.S BCHR=0 F S BCHR=$O(^TMP("BCHDR",$J,"DELETES",BCHV("R DATE"),BCHR)) Q:BCHR'=+BCHR D
..S DIE="^BCHEXDEL(",DA=BCHR,DR=".06////"_BCH("MAIN TX DATE") D CALLDIE^BCHUTIL
K ^TMP("BCHDR")
Q
PURGE2 ;
S BCHR="" F S BCHR=$O(^TMP("BCHDR",$J,BCHV("R DATE"),BCHR)) Q:BCHR="" D RESET
Q
;
RESET ; kill CHR xref and set flag if tx 23 or 24 generated
K ^BCHR("AEX",BCHV("R DATE"),BCHR)
I ^TMP("BCHDR",$J,"MAIN TX",BCHR)]"" S DIE="^BCHR(",DA=BCHR,DR=".19///"_^TMP("BCHDR",$J,"MAIN TX",BCHR) D CALLDIE^BCHUTIL
X BCHCNT
Q
;
;
CNTBUILD ;EP count and build tx
I BCHE]"" S BCH("ERROR COUNT")=BCH("ERROR COUNT")+1 D ^BCHEXERR Q
S BCH("COUNT")=BCH("COUNT")+1
S BCH(BCHRTYPE)=BCH(BCHRTYPE)+1
S BCHV("TX GENERATED")=1,^TMP("BCH"_$S(BCHO("RUN")="NEW":"DR",BCHO("RUN")="REDO":"REDO",1:"DR"),$J,"MAIN TX",BCHR)=BCH("MAIN TX DATE")
;S ^BCHRDATA(BCH("COUNT"))="CR^"_BCHTX ;IHS/CMI/LAB - new format
S ^BCHRDATA(BCH("COUNT"))=BCHTX
S X=0 F S X=$O(BCH("POVS",X)) Q:X'=+X S BCH("COUNT")=BCH("COUNT")+1,^BCHRDATA(BCH("COUNT"))=BCH("POVS",X) ;IHS/CMI/LAB - new format
Q
TAPE ; COPY TRANSACTIONS TO TAPE
D TAPE^BCHEXTAP
Q
;
CHKLOG ; CHECK LOG FILE
;S BCH("X")=0 F BCH("I")=BCH("RUN LOG"):-1:1 Q:'$D(^BCHXLOG(BCH("I"))) I $O(^BCHXLOG(BCH("I"),21,0)) S BCH("X")=BCH("X")+1
;I BCH("X")>12 W !,"-->There are more than twelve generations of CHR RECORDs stored in the LOG file.",!,"-->Time to do a purge."
Q
;
ABORT ; ABNORMAL TERMINATION
I $D(BCH("RUN LOG")) S BCH("QFLG1")=$O(^BCHDTER("B",BCH("QFLG"),"")),DA=BCH("RUN LOG"),DIE="^BCHXLOG(",DR=".15///F;.16////"_BCH("QFLG1")
I $D(ZTQUEUED) D ERRBULL^BCHEXDI3,EOJ Q
W !!,"Abnormal termination!! QFLG=",BCH("QFLG")
S DIR(0)="E",DIR("A")="DONE -- Press RETURN to Continue" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
D EOJ
Q
;
DELETES ;
D DELETES^BCHEXD2
Q
EOJ ; EOJ
D ^BCHEXEOJ
Q
BCHEXD ; IHS/CMI/LAB - MAIN DRIVER FOR CHR EXPORT TX GEN ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;IHS/CMI/LAB - PATCH 10 NEW RECORD FORMAT
+3 ;IHS/CMI/LAB ;added $J to ^TMP
+4 ;
+5 ;Main driver routine for the generation of transactions to be
+6 ;exported to the CHR System.
+7 ;
START ;
+1 IF $DATA(ZTQUEUED)
SET BCHO("SCHEDULED")=""
+2 ; Let BCHEXDI know this is a new run.
SET BCHO("RUN")="NEW"
+3 ; Do initialization
DO ^BCHEXDI
+4 IF $DATA(BCHO("QUEUE"))
DO EOJ
WRITE !!,"Okay, your request is queued! Bye",!
QUIT
+5 IF BCH("QFLG")=99
DO EOJ
WRITE !!,"Bye",!!
QUIT
+6 IF BCH("QFLG")
DO ABORT
QUIT
DRIVER ;called from TSKMN+2
+1 SET BCH("BT")=$HOROLOG
+2 DO NOW^%DTC
SET BCH("RUN START")=%
SET BCH("MAIN TX DATE")=$PIECE(%,".")
KILL %,%H,%I
+3 SET DIE="^BCHXLOG("
SET DA=BCH("RUN LOG")
SET DR=".15///R"_";.03////"_BCH("RUN START")
DO CALLDIE^BCHUTIL
+4 IF $DATA(Y)
DO ABORT
QUIT
+5 SET BCHCNT=$SELECT('$DATA(ZTQUEUED):"X BCHCNT1 X BCHCNT2",1:"S BCHCNTR=BCHCNTR+1")
SET BCHCNT1="F BCHCNTL=1:1:$L(BCHCNTR)+1 W @BCHBS"
SET BCHCNT2="S BCHCNTR=BCHCNTR+1 W BCHCNTR,"")"""
+6 ; Generate trasactions
DO PROCESS
+7 IF BCH("QFLG")
DO ABORT
QUIT
+8 ; Update Log
DO ^BCHEXLOG
+9 IF BCH("QFLG")
DO ABORT
QUIT
+10 ; Purge AEX xref entries
DO PURGE
+11 ; Show run time
DO RUNTIME^BCHEXEOJ
+12 ; Write transactions to tape
DO TAPE
+13 IF BCH("QFLG")
DO ABORT
QUIT
+14 ; See if Log needs cleaning
IF '$DATA(ZTQUEUED)
DO CHKLOG
+15 IF '$DATA(ZTQUEUED)
WRITE !!
SET DIR(0)="E"
SET DIR("A")="DONE -- Press RETURN to Continue"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+16 DO EOJ
+17 QUIT
+18 ;
PROCESS ;
+1 ;build header record
+2 ;S BCH("COUNT")=BCH("COUNT")+1
+3 IF '$DATA(ZTQUEUED)
WRITE !,"Generating transactions. Counting records. (1)"
+4 SET BCHCNTR=0
SET BCH("CONTROL DATE")=BCH("RUN BEGIN")-1
SET BCH("POSTING DATE")=" "
+5 SET BCHRTYPE="U"
+6 FOR
SET BCH("CONTROL DATE")=$ORDER(^BCHR("AEX",BCH("CONTROL DATE")))
IF BCH("CONTROL DATE")=""!(BCH("CONTROL DATE")>BCH("RUN END"))
QUIT
DO PROCESS2
IF BCH("QFLG")
QUIT
+7 ;gather up and send deletes
SET BCHRTYPE="D"
DO DELETES
+8 QUIT
PROCESS2 ;
+1 SET BCHR=""
FOR
SET BCHR=$ORDER(^BCHR("AEX",BCH("CONTROL DATE"),BCHR))
IF BCHR=""
QUIT
DO PROCESS3
IF BCH("QFLG")
QUIT
+2 QUIT
PROCESS3 ;
+1 ;IHS/CMI/LAB - missing record
IF '$DATA(^BCHR(BCHR,0))
KILL ^BCHR("AEX",BCH("CONTROL DATE"),BCHR)
QUIT
+2 KILL BCHE,BCHCPOV
+3 IF $DATA(^BCHXLOG(BCH("RUN LOG"),21,BCHR))
QUIT
+4 SET BCHV("TX GENERATED")=0
SET ^TMP("BCHDR",$JOB,BCH("CONTROL DATE"),BCHR)=""
SET ^TMP("BCHDR",$JOB,"MAIN TX",BCHR)=""
+5 SET BCH("VISIT COUNT")=BCH("VISIT COUNT")+1
+6 XECUTE BCHCNT
+7 IF '$DATA(^BCHRPROB("AD",BCHR))
SET BCHE="E021"
DO CNTBUILD
QUIT
+8 SET BCHREC=^BCHR(BCHR,0)
+9 KILL BCHE,BCHTX
SET (BCHCPOV,BCHPOVD)=0
FOR
SET BCHPOVD=$ORDER(^BCHRPROB("AD",BCHR,BCHPOVD))
IF BCHPOVD'=+BCHPOVD
QUIT
Begin DoDot:1
+10 IF $PIECE(^BCHRPROB(BCHPOVD,0),U,4)=""!($PIECE(^BCHRPROB(BCHPOVD,0),U,5)="")!($PIECE(^BCHRPROB(BCHPOVD,0),U,6)="")
SET BCHE="E021"
QUIT
+11 ;D RECORD^BCHEXD2
+12 ;D CNTBUILD
End DoDot:1
+13 ;IHS/CMI/LAB - new format
IF $DATA(BCHE)
DO CNTBUILD
QUIT
+14 DO ^XBFMK
+15 KILL BCHE,BCHTX,BCH("POVS")
+16 DO RECORD^BCHEXD2
+17 DO CNTBUILD
+18 SET DA=BCH("RUN LOG")
SET DR="2101///""`"_BCHR_""""
SET DIE="^BCHXLOG("
+19 SET DR(2,90002.912101)=".02////"_BCHV("TX GENERATED")_";.03///"_BCHRTYPE
+20 DO CALLDIE^BCHUTIL
+21 QUIT
+22 ;
PURGE ; PURGE 'AEX' XREF FOR CHR RECORDS JUST DONE
+1 IF '$DATA(ZTQUEUED)
WRITE !,"Deleting cross-reference entries. (1)"
+2 SET BCHCNTR=0
SET BCHV("R DATE")=""
+3 FOR
SET BCHV("R DATE")=$ORDER(^TMP("BCHDR",$JOB,BCHV("R DATE")))
IF BCHV("R DATE")'=+BCHV("R DATE")
QUIT
DO PURGE2
DEL ;update delete file
+1 SET BCHV("R DATE")=""
+2 FOR
SET BCHV("R DATE")=$ORDER(^TMP("BCHDR",$JOB,"DELETES",BCHV("R DATE")))
IF BCHV("R DATE")'=+BCHV("R DATE")
QUIT
Begin DoDot:1
+3 SET BCHR=0
FOR
SET BCHR=$ORDER(^TMP("BCHDR",$JOB,"DELETES",BCHV("R DATE"),BCHR))
IF BCHR'=+BCHR
QUIT
Begin DoDot:2
+4 SET DIE="^BCHEXDEL("
SET DA=BCHR
SET DR=".06////"_BCH("MAIN TX DATE")
DO CALLDIE^BCHUTIL
End DoDot:2
End DoDot:1
+5 KILL ^TMP("BCHDR")
+6 QUIT
PURGE2 ;
+1 SET BCHR=""
FOR
SET BCHR=$ORDER(^TMP("BCHDR",$JOB,BCHV("R DATE"),BCHR))
IF BCHR=""
QUIT
DO RESET
+2 QUIT
+3 ;
RESET ; kill CHR xref and set flag if tx 23 or 24 generated
+1 KILL ^BCHR("AEX",BCHV("R DATE"),BCHR)
+2 IF ^TMP("BCHDR",$JOB,"MAIN TX",BCHR)]""
SET DIE="^BCHR("
SET DA=BCHR
SET DR=".19///"_^TMP("BCHDR",$JOB,"MAIN TX",BCHR)
DO CALLDIE^BCHUTIL
+3 XECUTE BCHCNT
+4 QUIT
+5 ;
+6 ;
CNTBUILD ;EP count and build tx
+1 IF BCHE]""
SET BCH("ERROR COUNT")=BCH("ERROR COUNT")+1
DO ^BCHEXERR
QUIT
+2 SET BCH("COUNT")=BCH("COUNT")+1
+3 SET BCH(BCHRTYPE)=BCH(BCHRTYPE)+1
+4 SET BCHV("TX GENERATED")=1
SET ^TMP("BCH"_$SELECT(BCHO("RUN")="NEW":"DR",BCHO("RUN")="REDO":"REDO",1:"DR"),$JOB,"MAIN TX",BCHR)=BCH("MAIN TX DATE")
+5 ;S ^BCHRDATA(BCH("COUNT"))="CR^"_BCHTX ;IHS/CMI/LAB - new format
+6 SET ^BCHRDATA(BCH("COUNT"))=BCHTX
+7 ;IHS/CMI/LAB - new format
SET X=0
FOR
SET X=$ORDER(BCH("POVS",X))
IF X'=+X
QUIT
SET BCH("COUNT")=BCH("COUNT")+1
SET ^BCHRDATA(BCH("COUNT"))=BCH("POVS",X)
+8 QUIT
TAPE ; COPY TRANSACTIONS TO TAPE
+1 DO TAPE^BCHEXTAP
+2 QUIT
+3 ;
CHKLOG ; CHECK LOG FILE
+1 ;S BCH("X")=0 F BCH("I")=BCH("RUN LOG"):-1:1 Q:'$D(^BCHXLOG(BCH("I"))) I $O(^BCHXLOG(BCH("I"),21,0)) S BCH("X")=BCH("X")+1
+2 ;I BCH("X")>12 W !,"-->There are more than twelve generations of CHR RECORDs stored in the LOG file.",!,"-->Time to do a purge."
+3 QUIT
+4 ;
ABORT ; ABNORMAL TERMINATION
+1 IF $DATA(BCH("RUN LOG"))
SET BCH("QFLG1")=$ORDER(^BCHDTER("B",BCH("QFLG"),""))
SET DA=BCH("RUN LOG")
SET DIE="^BCHXLOG("
SET DR=".15///F;.16////"_BCH("QFLG1")
+2 IF $DATA(ZTQUEUED)
DO ERRBULL^BCHEXDI3
DO EOJ
QUIT
+3 WRITE !!,"Abnormal termination!! QFLG=",BCH("QFLG")
+4 SET DIR(0)="E"
SET DIR("A")="DONE -- Press RETURN to Continue"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+5 DO EOJ
+6 QUIT
+7 ;
DELETES ;
+1 DO DELETES^BCHEXD2
+2 QUIT
EOJ ; EOJ
+1 DO ^BCHEXEOJ
+2 QUIT
