ACHSEOB6 ; IHS/ITSC/PMF - PROCESS EOBRS (7/7) SUMMARY/ERROR REPORT ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,18,22,23**;JUN 11,2001;Build 43
;ACHS*3.1*13 JVK/SET/ITSC 8/22/05 FIX CLOSING SLAVE DEV
;
START ;EP - From TaskMan.
S ACHSSUM=0
S ACHS("R")=$O(^ACHSEOBR(0)),ACHSPG=0
G END:ACHS("R")=""
D SITENAME
S (ACHSFAC,ACHSOLD)="",ACHSEOIO=IO
K ^TMP("ACHSEOB",$J)
D BM^ACHSFU,NOW^ACHS
S X=ACHSTIME,ACHSTERR=0,ACHSLP=1 ;ACHS*3.1*22;ADDED ACHSLP
I ACHSRPT=1 S ACHSLP=0 W @IOF D HDR ;ACHS*3.1*22;ADDED ACHSLP
I ACHSRPT=2 S ACHSFAC=0 G PRNT2
I ACHSISAO D AREA G END
F S ACHSFAC=$O(^ACHSEOBR(ACHSFAC)) Q:+ACHSFAC'=ACHSFAC D Q:$D(DUOUT)!$D(DTOUT)
. ;ACHS*3.1*22 IHS.OIT.FCJ CHANGED NXT LINE TO START F LOOP TO ACHSLP VAR
. F ACHSCTR(1)=ACHSLP:0 Q:$D(DUOUT)!$D(DTOUT) S ACHSCTR(1)=$O(^ACHSEOBR(ACHSFAC,ACHSCTR(1))) Q:+ACHSCTR(1)'=ACHSCTR(1) S ACHSOLD=$E(^ACHSEOBR(ACHSFAC,ACHSCTR(1)),1,18) D PRNT
.Q
Q:$D(DUOUT)!$D(DTOUT) ;THIS USED TO BE A GOTO TO K^ACHSEOB5
W !?10,"TOTAL AMOUNT THIS RUN: ",?40
S X=ACHSSUM
D FMT^ACHS
W !!!
D RTRN^ACHS:ACHSRPT=2,FTR:ACHSRPT=1
I ACHSRPT=1 D DCR
;ACHS*3.1*13 ADDED TO PREVENT HANG OF SLAVE DEVICE JVK/SET/ITSC 8/22/05
D ^%ZISC
END ;
I ACHSRPT=2 S ACHSRPT=1 G START
Q
;
;
PRNT ;
F ACHSCTR=ACHSCTR(1):1 Q:'$D(^ACHSEOBR(ACHSFAC,ACHSCTR)) S ACHSEOBR=$G(^ACHSEOBR(ACHSFAC,ACHSCTR)) Q:$E(ACHSEOBR,1,18)'=ACHSOLD D PRT^ACHSEOBB
I ACHSISAO Q:ACHSFAC'=ACHSFAC(1)
I ACHSRPT=2,'$D(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1))) Q
;I ACHSRPT=2,$D(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1))) D ^ACHSEOB2 K ^TMP("ACHSEOB",$J) Q ;ACHS*3.1*22
;ACHS*3.1*23 ADDED K ACHSEOBR ARRAY IN NXT LINE
;I ACHSRPT=2,$D(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1))) D:$P($G(ACHSMEDA),".",2)'="ICD" ^ACHSEOB2 K ^TMP("ACHSEOB",$J) Q ;ACHS*3.1*22 DO NOT PRINT IF ICDFX
I ACHSRPT=2,$D(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1))) D:$P($G(ACHSMEDA),".",2)'="ICD" ^ACHSEOB2 S X=ACHSEOBR K ^TMP("ACHSEOB",$J),ACHSEOBR S ACHSEOBR=X Q ;ACHS*3.1*23 CLEAN UP VARS
;ACHS*3.1*23 TEST FOR DATA IN "B" REC
;I $D(^ACHSEOBR(ACHSFAC,ACHSCTR(1))) D W1 W ?34,ACHSEOBR("B",8) D COST W !
I $D(^ACHSEOBR(ACHSFAC,ACHSCTR(1))),$D(ACHSEOBR("B",8)) D W1 W ?34,ACHSEOBR("B",8) D COST W !
P0 ;
S ACHS="",ACHSER1=0
F S ACHS=$O(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1),ACHS)) Q:ACHS="" D
. S ACHSER=$P($T(@ACHS^ACHSEOBG),";",4),ACHSDESC=$P($T(@ACHS^ACHSEOBG),";",3)
. I ACHSER="E" S ACHSSUM=ACHSSUM-ACHSCOST
. F I=1:1 S ACHSEDAT=$P(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1),ACHS),U,I) Q:(ACHSEDAT="")&(I>1) W ?29,ACHSER_ACHS,?34,ACHSDESC W:ACHSEDAT]"" ?55,"(",ACHSEDAT,")" W ! S ACHSER1=1 Q:ACHSEDAT=""
P1 ;
I ACHSRPT=2 D RTRN^ACHS
K ^TMP("ACHSEOB",$J),ACHSEOBR
I ACHSRPT=1,$Y>(ACHSBM-4) D FTR I '$D(DUOUT),'$D(DTOUT) D HDR
S ACHSCTR(1)=$S($D(^ACHSEOBR(ACHSFAC,ACHSCTR)):ACHSCTR-1,1:ACHSCTR)
Q
;
W1 ;
;ACHS*3.1*22 ADDED TEST FOR DATA BELOW
W:$D(ACHSEOBR("A")) $J(+ACHSEOBR("A",8),5),?6,ACHSEOBR("A",14)," ",$E(ACHSEOBR("A",12),2,12)," "," ",ACHSEOBR("C",13)," "," "," ",ACHSEOBR("A",15)," "
Q
;
COST ;
;ACHS*3.1*23 CHG "E" TO VAR ACHSREJ FOR REC E OR J
S ACHSREJ=$S($D(ACHSEOBR("E")):"E",$D(ACHSEOBR("J")):"J",1:"")
W ?70,$J($FN(+$E(ACHSEOBR(ACHSREJ,8),1,7)_"."_$E(ACHSEOBR(ACHSREJ,8),8,9),",",2),8)
S ACHSCOST=$E(ACHSEOBR(ACHSREJ,8),1,7)_"."_$E(ACHSEOBR(ACHSREJ,8),8,9)
S ACHSSUM=ACHSSUM+ACHSCOST
Q
;
PRNT2 ;
S ACHSFAC=$O(^ACHSEOBR("ER",ACHSFAC))
G END:ACHSFAC=""
W @IOF
S ACHSCTR(1)=0
PRNT2A ;
S ACHSCTR(1)=$O(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1)))
G PRNT2:ACHSCTR(1)=""
S ACHSOLD=$E(^ACHSEOBR(ACHSFAC,ACHSCTR(1)),1,18)
D PRNT,RTRN^ACHS
Q:$D(DUOUT)!$D(DTOUT) ;USED TO BE G K^ACHSEOB5
G PRNT2A
;
HDR ;
U IO
S ACHSPG=ACHSPG+1
W ACHSTIME,?28,"CHS EOBR PROCESSING REPORT",?67,"PAGE ",$J(ACHSPG,3),!,?24,"for Documents Paid on: ",$$FMTE^XLFDT(ACHSEOBD),!,?40-(($L(ACHS("SITE"))+4)\2),"for ",ACHS("SITE"),!
HDR2 ;
W !!,"COUNT SITE P.O. NUMBER P-T CODE DESCRIPTION or PATIENT",?70,"IHS COST",!,"----- ------ ----------- --- ---- ------------------------------",?70,"--------",!!
Q
;
SITENAME ;
S ACHS("SITE")=$P(^DIC(4,ACHS("R"),0),U,1)
Q
;
FTR ; Print footer, do EOP, TOP.
W !,"'COUNT' appears at the upper right of the EOBR.",!,"If 'CODE' begins with 'E', the P.O. was not processed.",!,"If 'CODE' begins with 'W', the P.O. was processed but needs further attention.",!
D RTRN^ACHS
Q:$D(DUOUT)!$D(DTOUT)
W @IOF
Q
;
AREA ;
S (ACHSFAC,ACHSCTR,ACHSCTR(1),ACHSFAC(1))=0
AREA1 ;
S ACHSFAC=$O(^ACHSEOBR(ACHSFAC))
Q:+ACHSFAC'=ACHSFAC
Q:ACHSFAC=""
S ACHS("R")=ACHSFAC
D SITENAME
I ACHSFAC'=ACHSFAC(1),ACHSFAC(1)'=0 D FTR Q:$D(DUOUT)!$D(DTOUT) D HDR
AREA2 ;
S ACHSCTR(1)=$O(^ACHSEOBR(ACHSFAC,ACHSCTR(1)))
G AREA1:ACHSCTR(1)=""
S ACHSOLD=$E(^ACHSEOBR(ACHSFAC,ACHSCTR(1)),1,18),ACHSFAC(1)=ACHSFAC
D PRNT
Q:$D(DUOUT)!$D(DTOUT) ;USED TO BE G K^ACHSEOB5
G AREA2
;
DCR ; Print Begin/End values of DCRs
N %,B,E,N,R,X,Y
S N=$G(^ACHS(9,DUZ(2),"RN")),Y=0
F S Y=$O(^ACHSEOBR("DCR",Y)) Q:'Y D Q:$G(ACHSQUIT)
. I '$D(^ACHSEOBR("DCR",Y,"E")) S ^ACHSEOBR("DCR",Y,"E")=$G(^ACHSEOBR("DCR",Y,"B"))
. I $G(^ACHSEOBR("DCR",Y,"B"))=$G(^ACHSEOBR("DCR",Y,"E")) Q
. S B=$G(^ACHSEOBR("DCR",Y,"B"))
. S E=$G(^ACHSEOBR("DCR",Y,"E"))
. W !!,Y," Registers",?29,"Before",?45,"After",?59,"Change"
. W !,$$R(20),?22,$$R(13),?37,$$R(13),?52,$$R(13)
. F %=1:1:7 S R=$P(N,U,%)_$$REPEAT^XLFSTR(".",20) W !,$E(R,1,20),$J($FN($P(B,U,%),",",2),15),$J($FN($P(E,U,%),",",2),15),$J($FN($P(B,U,%)-$P(E,U,%),",",2),15)
. D RTRN
.Q
Q
;
R(A) ;
Q $$REPEAT^XLFSTR("-",A)
;
RTRN ;
N %,B,E,N,R,X,Y
D RTRN^ACHS
Q
ACHSEOB6 ; IHS/ITSC/PMF - PROCESS EOBRS (7/7) SUMMARY/ERROR REPORT ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,18,22,23**;JUN 11,2001;Build 43
+2 ;ACHS*3.1*13 JVK/SET/ITSC 8/22/05 FIX CLOSING SLAVE DEV
+3 ;
START ;EP - From TaskMan.
+1 SET ACHSSUM=0
+2 SET ACHS("R")=$ORDER(^ACHSEOBR(0))
SET ACHSPG=0
+3 IF ACHS("R")=""
GOTO END
+4 DO SITENAME
+5 SET (ACHSFAC,ACHSOLD)=""
SET ACHSEOIO=IO
+6 KILL ^TMP("ACHSEOB",$JOB)
+7 DO BM^ACHSFU
DO NOW^ACHS
+8 ;ACHS*3.1*22;ADDED ACHSLP
SET X=ACHSTIME
SET ACHSTERR=0
SET ACHSLP=1
+9 ;ACHS*3.1*22;ADDED ACHSLP
IF ACHSRPT=1
SET ACHSLP=0
WRITE @IOF
DO HDR
+10 IF ACHSRPT=2
SET ACHSFAC=0
GOTO PRNT2
+11 IF ACHSISAO
DO AREA
GOTO END
+12 FOR
SET ACHSFAC=$ORDER(^ACHSEOBR(ACHSFAC))
IF +ACHSFAC'=ACHSFAC
QUIT
Begin DoDot:1
+13 ;ACHS*3.1*22 IHS.OIT.FCJ CHANGED NXT LINE TO START F LOOP TO ACHSLP VAR
+14 FOR ACHSCTR(1)=ACHSLP:0
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
SET ACHSCTR(1)=$ORDER(^ACHSEOBR(ACHSFAC,ACHSCTR(1)))
IF +ACHSCTR(1)'=ACHSCTR(1)
QUIT
SET ACHSOLD=$EXTRACT(^ACHSEOBR(ACHSFAC,ACHSCTR(1)),1,18)
DO PRNT
+15 QUIT
End DoDot:1
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+16 ;THIS USED TO BE A GOTO TO K^ACHSEOB5
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+17 WRITE !?10,"TOTAL AMOUNT THIS RUN: ",?40
+18 SET X=ACHSSUM
+19 DO FMT^ACHS
+20 WRITE !!!
+21 IF ACHSRPT=2
DO RTRN^ACHS
IF ACHSRPT=1
DO FTR
+22 IF ACHSRPT=1
DO DCR
+23 ;ACHS*3.1*13 ADDED TO PREVENT HANG OF SLAVE DEVICE JVK/SET/ITSC 8/22/05
+24 DO ^%ZISC
END ;
+1 IF ACHSRPT=2
SET ACHSRPT=1
GOTO START
+2 QUIT
+3 ;
+4 ;
PRNT ;
+1 FOR ACHSCTR=ACHSCTR(1):1
IF '$DATA(^ACHSEOBR(ACHSFAC,ACHSCTR))
QUIT
SET ACHSEOBR=$GET(^ACHSEOBR(ACHSFAC,ACHSCTR))
IF $EXTRACT(ACHSEOBR,1,18)'=ACHSOLD
QUIT
DO PRT^ACHSEOBB
+2 IF ACHSISAO
IF ACHSFAC'=ACHSFAC(1)
QUIT
+3 IF ACHSRPT=2
IF '$DATA(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1)))
QUIT
+4 ;I ACHSRPT=2,$D(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1))) D ^ACHSEOB2 K ^TMP("ACHSEOB",$J) Q ;ACHS*3.1*22
+5 ;ACHS*3.1*23 ADDED K ACHSEOBR ARRAY IN NXT LINE
+6 ;I ACHSRPT=2,$D(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1))) D:$P($G(ACHSMEDA),".",2)'="ICD" ^ACHSEOB2 K ^TMP("ACHSEOB",$J) Q ;ACHS*3.1*22 DO NOT PRINT IF ICDFX
+7 ;ACHS*3.1*23 CLEAN UP VARS
IF ACHSRPT=2
IF $DATA(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1)))
IF $PIECE($GET(ACHSMEDA),".",2)'="ICD"
DO ^ACHSEOB2
SET X=ACHSEOBR
KILL ^TMP("ACHSEOB",$JOB),ACHSEOBR
SET ACHSEOBR=X
QUIT
+8 ;ACHS*3.1*23 TEST FOR DATA IN "B" REC
+9 ;I $D(^ACHSEOBR(ACHSFAC,ACHSCTR(1))) D W1 W ?34,ACHSEOBR("B",8) D COST W !
+10 IF $DATA(^ACHSEOBR(ACHSFAC,ACHSCTR(1)))
IF $DATA(ACHSEOBR("B",8))
DO W1
WRITE ?34,ACHSEOBR("B",8)
DO COST
WRITE !
P0 ;
+1 SET ACHS=""
SET ACHSER1=0
+2 FOR
SET ACHS=$ORDER(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1),ACHS))
IF ACHS=""
QUIT
Begin DoDot:1
+3 SET ACHSER=$PIECE($TEXT(@ACHS^ACHSEOBG),";",4)
SET ACHSDESC=$PIECE($TEXT(@ACHS^ACHSEOBG),";",3)
+4 IF ACHSER="E"
SET ACHSSUM=ACHSSUM-ACHSCOST
+5 FOR I=1:1
SET ACHSEDAT=$PIECE(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1),ACHS),U,I)
IF (ACHSEDAT="")&(I>1)
QUIT
WRITE ?29,ACHSER_ACHS,?34,ACHSDESC
IF ACHSEDAT]""
WRITE ?55,"(",ACHSEDAT,")"
WRITE !
SET ACHSER1=1
IF ACHSEDAT=""
QUIT
End DoDot:1
P1 ;
+1 IF ACHSRPT=2
DO RTRN^ACHS
+2 KILL ^TMP("ACHSEOB",$JOB),ACHSEOBR
+3 IF ACHSRPT=1
IF $Y>(ACHSBM-4)
DO FTR
IF '$DATA(DUOUT)
IF '$DATA(DTOUT)
DO HDR
+4 SET ACHSCTR(1)=$SELECT($DATA(^ACHSEOBR(ACHSFAC,ACHSCTR)):ACHSCTR-1,1:ACHSCTR)
+5 QUIT
+6 ;
W1 ;
+1 ;ACHS*3.1*22 ADDED TEST FOR DATA BELOW
+2 IF $DATA(ACHSEOBR("A"))
WRITE $JUSTIFY(+ACHSEOBR("A",8),5),?6,ACHSEOBR("A",14)," ",$EXTRACT(ACHSEOBR("A",12),2,12)," "," ",ACHSEOBR("C",13)," "," "," ",ACHSEOBR("A",15)," "
+3 QUIT
+4 ;
COST ;
+1 ;ACHS*3.1*23 CHG "E" TO VAR ACHSREJ FOR REC E OR J
+2 SET ACHSREJ=$SELECT($DATA(ACHSEOBR("E")):"E",$DATA(ACHSEOBR("J")):"J",1:"")
+3 WRITE ?70,$JUSTIFY($FNUMBER(+$EXTRACT(ACHSEOBR(ACHSREJ,8),1,7)_"."_$EXTRACT(ACHSEOBR(ACHSREJ,8),8,9),",",2),8)
+4 SET ACHSCOST=$EXTRACT(ACHSEOBR(ACHSREJ,8),1,7)_"."_$EXTRACT(ACHSEOBR(ACHSREJ,8),8,9)
+5 SET ACHSSUM=ACHSSUM+ACHSCOST
+6 QUIT
+7 ;
PRNT2 ;
+1 SET ACHSFAC=$ORDER(^ACHSEOBR("ER",ACHSFAC))
+2 IF ACHSFAC=""
GOTO END
+3 WRITE @IOF
+4 SET ACHSCTR(1)=0
PRNT2A ;
+1 SET ACHSCTR(1)=$ORDER(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1)))
+2 IF ACHSCTR(1)=""
GOTO PRNT2
+3 SET ACHSOLD=$EXTRACT(^ACHSEOBR(ACHSFAC,ACHSCTR(1)),1,18)
+4 DO PRNT
DO RTRN^ACHS
+5 ;USED TO BE G K^ACHSEOB5
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+6 GOTO PRNT2A
+7 ;
HDR ;
+1 USE IO
+2 SET ACHSPG=ACHSPG+1
+3 WRITE ACHSTIME,?28,"CHS EOBR PROCESSING REPORT",?67,"PAGE ",$JUSTIFY(ACHSPG,3),!,?24,"for Documents Paid on: ",$$FMTE^XLFDT(ACHSEOBD),!,?40-(($LENGTH(ACHS("SITE"))+4)\2),"for ",ACHS("SITE"),!
HDR2 ;
+1 WRITE !!,"COUNT SITE P.O. NUMBER P-T CODE DESCRIPTION or PATIENT",?70,"IHS COST",!,"----- ------ ----------- --- ---- ------------------------------",?70,"--------",!!
+2 QUIT
+3 ;
SITENAME ;
+1 SET ACHS("SITE")=$PIECE(^DIC(4,ACHS("R"),0),U,1)
+2 QUIT
+3 ;
FTR ; Print footer, do EOP, TOP.
+1 WRITE !,"'COUNT' appears at the upper right of the EOBR.",!,"If 'CODE' begins with 'E', the P.O. was not processed.",!,"If 'CODE' begins with 'W', the P.O. was processed but needs further attention.",!
+2 DO RTRN^ACHS
+3 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+4 WRITE @IOF
+5 QUIT
+6 ;
AREA ;
+1 SET (ACHSFAC,ACHSCTR,ACHSCTR(1),ACHSFAC(1))=0
AREA1 ;
+1 SET ACHSFAC=$ORDER(^ACHSEOBR(ACHSFAC))
+2 IF +ACHSFAC'=ACHSFAC
QUIT
+3 IF ACHSFAC=""
QUIT
+4 SET ACHS("R")=ACHSFAC
+5 DO SITENAME
+6 IF ACHSFAC'=ACHSFAC(1)
IF ACHSFAC(1)'=0
DO FTR
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
DO HDR
AREA2 ;
+1 SET ACHSCTR(1)=$ORDER(^ACHSEOBR(ACHSFAC,ACHSCTR(1)))
+2 IF ACHSCTR(1)=""
GOTO AREA1
+3 SET ACHSOLD=$EXTRACT(^ACHSEOBR(ACHSFAC,ACHSCTR(1)),1,18)
SET ACHSFAC(1)=ACHSFAC
+4 DO PRNT
+5 ;USED TO BE G K^ACHSEOB5
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+6 GOTO AREA2
+7 ;
DCR ; Print Begin/End values of DCRs
+1 NEW %,B,E,N,R,X,Y
+2 SET N=$GET(^ACHS(9,DUZ(2),"RN"))
SET Y=0
+3 FOR
SET Y=$ORDER(^ACHSEOBR("DCR",Y))
IF 'Y
QUIT
Begin DoDot:1
+4 IF '$DATA(^ACHSEOBR("DCR",Y,"E"))
SET ^ACHSEOBR("DCR",Y,"E")=$GET(^ACHSEOBR("DCR",Y,"B"))
+5 IF $GET(^ACHSEOBR("DCR",Y,"B"))=$GET(^ACHSEOBR("DCR",Y,"E"))
QUIT
+6 SET B=$GET(^ACHSEOBR("DCR",Y,"B"))
+7 SET E=$GET(^ACHSEOBR("DCR",Y,"E"))
+8 WRITE !!,Y," Registers",?29,"Before",?45,"After",?59,"Change"
+9 WRITE !,$$R(20),?22,$$R(13),?37,$$R(13),?52,$$R(13)
+10 FOR %=1:1:7
SET R=$PIECE(N,U,%)_$$REPEAT^XLFSTR(".",20)
WRITE !,$EXTRACT(R,1,20),$JUSTIFY($FNUMBER($PIECE(B,U,%),",",2),15),$JUSTIFY($FNUMBER($PIECE(E,U,%),",",2),15),$JUSTIFY($FNUMBER($PIECE(B,U,%)-$PIECE(E,U,%),",",2),15)
+11 DO RTRN
+12 QUIT
End DoDot:1
IF $GET(ACHSQUIT)
QUIT
+13 QUIT
+14 ;
R(A) ;
+1 QUIT $$REPEAT^XLFSTR("-",A)
+2 ;
RTRN ;
+1 NEW %,B,E,N,R,X,Y
+2 DO RTRN^ACHS
+3 QUIT
