ACHSDSU ; IHS/ITSC/PMF - DOCUMENT SUMMARY REPORT ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
TITLE ;;CHS DOCUMENT SUMMARY
;
BDT ;
S ACHSBDT=$$DATE^ACHS("B",$P($T(TITLE),";",3))
I $D(DTOUT)!$D(DUOUT)!(ACHSBDT<1) D K Q
EDT ;
S ACHSEDT=$$DATE^ACHS("E",$P($T(TITLE),";",3))
I $D(DTOUT)!(ACHSEDT<1) D K Q
G BDT:$D(DUOUT)
G:$$EBB^ACHS(ACHSBDT,ACHSEDT) BDT
S ACHSIO=IO
DEV ;
S %=$$PB^ACHS
I %=U!$D(DTOUT)!$D(DUOUT) D K Q
I %="B" D VIEWR^XBLM("START^ACHSDSU"),EN^XBVK("VALM"),K Q
S %ZIS="OPQ"
D ^%ZIS
I POP D HOME^%ZIS G K
G:'$D(IO("Q")) START
K IO("Q")
I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
S ZTRTN="START^ACHSDSU",ZTIO="",ZTDESC=$P($T(TITLE),";",3)_", "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT)_".",ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
F ACHS="ACHSQIO","ACHSBDT","ACHSEDT" S ZTSAVE(ACHS)=""
D ^%ZTLOAD
G:'$D(ZTSK) DEV
K ;
D ^%ZISC
K DTOUT,DUOUT,ZTIO,ZTSK
D EN^XBVK("ACHS"),^ACHSVAR
Q
;
START ;EP - TaskMan.
K ^TMP($J,"ACHSDSU")
S ACHSCHS=""
D ^ACHSUF
S ^TMP($J,"ACHSDSU","TRAN")=0,^TMP($J,"ACHSDSU","TOTAL")=0,ACHSTRDT=ACHSBDT-1,ACHSTY=""
A1 ;
S ACHSTRDT=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT))
I ACHSTRDT>ACHSEDT D END Q
I ACHSTRDT="" D END Q
S ACHSACT=""
A2 ;
S ACHSACT=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSACT))
G A1:ACHSACT=""
S ACHSDIEN=""
A3 ;
S ACHSDIEN=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSACT,ACHSDIEN))
G A2:ACHSDIEN=""
G A3:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
S ACHSDOCR=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),ACHSACN=""
S N=$P(ACHSDOCR,U,6),O=$P(ACHSDOCR,U,7),ACHSDEST=$S($P(ACHSDOCR,U,17)="I":"IHS",$P(ACHSDOCR,U,17)="":"IHS",1:"FISCAL AGENT")
K ACHSBLKF
I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"BT")) S ACHSBLKF=""
S R=$P(ACHSDOCR,U,19),ACHSADS=ACHSTRDT_U_$P(ACHSDIEN,U)_U_R_U_$P(ACHSDOCR,U,8)_U
S ACHSX=$P(ACHSDOCR,U,14)
D FYCVT^ACHSFU
S ACHSACFY=ACHSY
A4 ;
S ACHSACN=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSACT,ACHSDIEN,ACHSACN))
G A3:ACHSACN=""
G A4:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0))
S ACHSTRAN=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0))
S:$D(^ACHSF(DUZ(2),"D",ACHSDIEN,0)) ACHSACD=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U)
S ACHSSET=0,X=$P(ACHSTRAN,U,2),DFN=$P(ACHSTRAN,U,3),Y=$P(ACHSTRAN,U,5),A=$P(ACHSTRAN,U,4),T=X,O=A
I X="C"&(Y="P") S T="D"
I T'="P" S A=0 G A5
G A6:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) S O=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),A=$P(O,U),O=$P(O,U,2)
I 'O G A6
A5 ;
S ACHSTS=DFN_U_T_U_O_U_A_U_$P(ACHSTRAN,U,10),ACHSSET=1
A6 ;
I ACHSSET S ^TMP($J,"ACHSDSU",ACHSACFY,ACHSACD,ACHSDIEN,ACHSACN)=ACHSADS_ACHSTS,ACHSTY=ACHSACT S:ACHSTY="C" O="-"_O
I ACHSSET S ^TMP($J,"ACHSDSU","TRAN")=$G(^TMP($J,"ACHSDSU","TRAN"))+1,^TMP($J,"ACHSDSU","TOTAL")=$G(^TMP($J,"ACHSDSU","TOTAL"))+O
;
;WHY IS "ZA" TYPE IGNORED?????
S ACHSTY=$S(ACHSTY="I":"INITIAL",ACHSTY="P":"PAYMENT",ACHSTY="S":"SUPPLEMENTAL",ACHSTY="IP":"INTERIM PAYMENT",1:"CANCEL")
;
I ACHSSET,$D(ACHSTY) S:'$D(^TMP($J,"ACHSDSU",ACHSTY)) ^TMP($J,"ACHSDSU",ACHSTY)=0 S X=$G(^TMP($J,"ACHSDSU",ACHSTY)),$P(X,U)=$P(X,U)+1,$P(X,U,2)=$P(X,U,2)+O,^TMP($J,"ACHSDSU",ACHSTY)=X
S:'$D(^TMP($J,"ACHSDSU",ACHSDEST)) ^TMP($J,"ACHSDSU",ACHSDEST)=0
S ^TMP($J,"ACHSDSU",ACHSDEST)=$G(^TMP($J,"ACHSDSU",ACHSDEST))+1
G A4
;
END ; Kill routine vars, print.
K ACHSDEST,ACHSDOCR,ACHSTRAN,ACHSTRDT,ACHSTS,ACHSX,ACHSY
D BRPT^ACHSFU ;
S (ACHSACFY,ACHSPG)=0,ACHS=""
D ^ACHSUF ;CHECK DATA INTEGRITY HE,HE,HE
S ACHSLOC=$$C^XBFUNC($$LOC^ACHS,80),ACHST1=$$C^XBFUNC($$FMTE^XLFDT(ACHSBDT)_" Thru "_$$FMTE^XLFDT(ACHSEDT))
K ACHSSUM
F ACHS=1:1:7 S ACHSSUM(ACHS)=""
S ACHSACFY=0
U IO
FY ;
S ACHSACFY=$O(^TMP($J,"ACHSDSU",ACHSACFY))
I ACHSACFY<1 D HDR,SUM,RGSTRS G KILL
D HDR,HDR1^ACHSODP
S ACHSACD="",ACHSDIEN=0,ACHSDPFX=$E(ACHSACFY,4)_"-"_ACHSFC_"-"
CODE ;
S ACHSACD=$O(^TMP($J,"ACHSDSU",ACHSACFY,ACHSACD))
I ACHSACD="" D RTRN^ACHS G KILL:$D(DUOUT)!$D(DTOUT),FY
S ACHSDIEN=0
DOC ;
S ACHSDIEN=$O(^TMP($J,"ACHSDSU",ACHSACFY,ACHSACD,ACHSDIEN))
G CODE:ACHSDIEN<1
S ACHSTN=0
TRANS ;
S ACHSTN=$O(^TMP($J,"ACHSDSU",ACHSACFY,ACHSACD,ACHSDIEN,ACHSTN)) G DOC:ACHSTN<1 S ACHSACS=$G(^TMP($J,"ACHSDSU",ACHSACFY,ACHSACD,ACHSDIEN,ACHSTN))
I $Y>ACHSBM D RTRN^ACHS G KILL:$D(DUOUT)!$D(DTOUT) D HDR,HDR1^ACHSODP
D ^ACHSODP1
G TRANS
;
KILL ;
W @IOF
K ZTSK
D ERPT^ACHS
K B,C,DFN,L,N,O,S,T
D EN^XBVK("ACHS"),^ACHSVAR:'$D(ZTQUEUED)
Q
;
HDR ;
S ACHSPG=ACHSPG+1
W @IOF,!,ACHSLOC,!?26,"CHS DOCUMENT SUMMARY REPORT",?71,"Page",$J(ACHSPG,4),!,ACHSTIME,!,ACHST1,!!
Q
;
SUM ;
D HDR2^ACHSODP
S ACHSCT=0,X2="2$",X3=15
F ACHSTYPE="INITIAL","SUPPLEMENTAL","CANCEL","PAYMENT","INTERIM PAYMENT" D
. W !?5,ACHSTYPE," DOCUMENTS"
. I $D(^TMP($J,"ACHSDSU",ACHSTYPE)) S X=$P(^(ACHSTYPE),U,2),ACHSCT=ACHSCT+X D COMMA^%DTC W ?43,$J($P(^TMP($J,"ACHSDSU",ACHSTYPE),U),6),?60,X
.Q
S X=ACHSCT
D COMMA^%DTC
W !?43,"________",?62,"_____________",!!?5,"TOTALS",?44,$J(^TMP($J,"ACHSDSU","TRAN"),5),?60,X
W !!!?5,"FISCAL AGENT DOCUMENTS:",$S($D(^TMP($J,"ACHSDSU","FISCAL AGENT")):$J(^("FISCAL AGENT"),5),1:" 0"),!?14,"IHS DOCUMENTS:",$S($D(^TMP($J,"ACHSDSU","IHS")):$J(^("IHS"),5),1:" 0"),!
D RTRN^ACHS
Q
;
RGSTRS ;
D HDR,SB2^ACHSODP2
S ACHSACTN=$S($D(^ACHS(9,DUZ(2),"RN")):^("RN"),1:""),X2=2,X3=12
F ACHS=1:1:7 S $P(ACHSSUM(ACHS),U,3)=$P(ACHSSUM(ACHS),U)-$P(ACHSSUM(ACHS),U,2)
F ACHSX1=1:1:7 W !,$E($P(ACHSACTN,U,ACHSX1),1,20),?30 D SB1 W:ACHSX1<7 !
W !
D S21^ACHSODP2
W !,"TOTAL",?30
S X=0
F ACHSX=1,2,3 F ACHS=1:1:7 S X=X+$P(ACHSSUM(ACHS),U,ACHSX) I ACHS=7 W $J($FN(X,",",2),12) S ACHSACTO=X,X=0
W $J($FN(ACHSACTO,",",2),12),!!!?1,"Obligated Balance For Period: ",$J("$"_$FN(ACHSACTO,",",2),14)
K ACHSX1,X2
D RTRN^ACHS
Q
;
SB1 ;
F ACHSX=1,2,3,3 W $J($FN($P(ACHSSUM(ACHSX1),U,ACHSX),",",2),12)
Q
;
ACHSDSU ; IHS/ITSC/PMF - DOCUMENT SUMMARY REPORT ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
TITLE ;;CHS DOCUMENT SUMMARY
+1 ;
BDT ;
+1 SET ACHSBDT=$$DATE^ACHS("B",$PIECE($TEXT(TITLE),";",3))
+2 IF $DATA(DTOUT)!$DATA(DUOUT)!(ACHSBDT<1)
DO K
QUIT
EDT ;
+1 SET ACHSEDT=$$DATE^ACHS("E",$PIECE($TEXT(TITLE),";",3))
+2 IF $DATA(DTOUT)!(ACHSEDT<1)
DO K
QUIT
+3 IF $DATA(DUOUT)
GOTO BDT
+4 IF $$EBB^ACHS(ACHSBDT,ACHSEDT)
GOTO BDT
+5 SET ACHSIO=IO
DEV ;
+1 SET %=$$PB^ACHS
+2 IF %=U!$DATA(DTOUT)!$DATA(DUOUT)
DO K
QUIT
+3 IF %="B"
DO VIEWR^XBLM("START^ACHSDSU")
DO EN^XBVK("VALM")
DO K
QUIT
+4 SET %ZIS="OPQ"
+5 DO ^%ZIS
+6 IF POP
DO HOME^%ZIS
GOTO K
+7 IF '$DATA(IO("Q"))
GOTO START
+8 KILL IO("Q")
+9 IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+10 SET ZTRTN="START^ACHSDSU"
SET ZTIO=""
SET ZTDESC=$PIECE($TEXT(TITLE),";",3)_", "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT)_"."
SET ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
+11 FOR ACHS="ACHSQIO","ACHSBDT","ACHSEDT"
SET ZTSAVE(ACHS)=""
+12 DO ^%ZTLOAD
+13 IF '$DATA(ZTSK)
GOTO DEV
K ;
+1 DO ^%ZISC
+2 KILL DTOUT,DUOUT,ZTIO,ZTSK
+3 DO EN^XBVK("ACHS")
DO ^ACHSVAR
+4 QUIT
+5 ;
START ;EP - TaskMan.
+1 KILL ^TMP($JOB,"ACHSDSU")
+2 SET ACHSCHS=""
+3 DO ^ACHSUF
+4 SET ^TMP($JOB,"ACHSDSU","TRAN")=0
SET ^TMP($JOB,"ACHSDSU","TOTAL")=0
SET ACHSTRDT=ACHSBDT-1
SET ACHSTY=""
A1 ;
+1 SET ACHSTRDT=$ORDER(^ACHSF(DUZ(2),"TB",ACHSTRDT))
+2 IF ACHSTRDT>ACHSEDT
DO END
QUIT
+3 IF ACHSTRDT=""
DO END
QUIT
+4 SET ACHSACT=""
A2 ;
+1 SET ACHSACT=$ORDER(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSACT))
+2 IF ACHSACT=""
GOTO A1
+3 SET ACHSDIEN=""
A3 ;
+1 SET ACHSDIEN=$ORDER(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSACT,ACHSDIEN))
+2 IF ACHSDIEN=""
GOTO A2
+3 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
GOTO A3
+4 SET ACHSDOCR=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
SET ACHSACN=""
+5 SET N=$PIECE(ACHSDOCR,U,6)
SET O=$PIECE(ACHSDOCR,U,7)
SET ACHSDEST=$SELECT($PIECE(ACHSDOCR,U,17)="I":"IHS",$PIECE(ACHSDOCR,U,17)="":"IHS",1:"FISCAL AGENT")
+6 KILL ACHSBLKF
+7 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"BT"))
SET ACHSBLKF=""
+8 SET R=$PIECE(ACHSDOCR,U,19)
SET ACHSADS=ACHSTRDT_U_$PIECE(ACHSDIEN,U)_U_R_U_$PIECE(ACHSDOCR,U,8)_U
+9 SET ACHSX=$PIECE(ACHSDOCR,U,14)
+10 DO FYCVT^ACHSFU
+11 SET ACHSACFY=ACHSY
A4 ;
+1 SET ACHSACN=$ORDER(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSACT,ACHSDIEN,ACHSACN))
+2 IF ACHSACN=""
GOTO A3
+3 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0))
GOTO A4
+4 SET ACHSTRAN=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0))
+5 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
SET ACHSACD=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U)
+6 SET ACHSSET=0
SET X=$PIECE(ACHSTRAN,U,2)
SET DFN=$PIECE(ACHSTRAN,U,3)
SET Y=$PIECE(ACHSTRAN,U,5)
SET A=$PIECE(ACHSTRAN,U,4)
SET T=X
SET O=A
+7 IF X="C"&(Y="P")
SET T="D"
+8 IF T'="P"
SET A=0
GOTO A5
+9 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))
GOTO A6
SET O=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))
SET A=$PIECE(O,U)
SET O=$PIECE(O,U,2)
+10 IF 'O
GOTO A6
A5 ;
+1 SET ACHSTS=DFN_U_T_U_O_U_A_U_$PIECE(ACHSTRAN,U,10)
SET ACHSSET=1
A6 ;
+1 IF ACHSSET
SET ^TMP($JOB,"ACHSDSU",ACHSACFY,ACHSACD,ACHSDIEN,ACHSACN)=ACHSADS_ACHSTS
SET ACHSTY=ACHSACT
IF ACHSTY="C"
SET O="-"_O
+2 IF ACHSSET
SET ^TMP($JOB,"ACHSDSU","TRAN")=$GET(^TMP($JOB,"ACHSDSU","TRAN"))+1
SET ^TMP($JOB,"ACHSDSU","TOTAL")=$GET(^TMP($JOB,"ACHSDSU","TOTAL"))+O
+3 ;
+4 ;WHY IS "ZA" TYPE IGNORED?????
+5 SET ACHSTY=$SELECT(ACHSTY="I":"INITIAL",ACHSTY="P":"PAYMENT",ACHSTY="S":"SUPPLEMENTAL",ACHSTY="IP":"INTERIM PAYMENT",1:"CANCEL")
+6 ;
+7 IF ACHSSET
IF $DATA(ACHSTY)
IF '$DATA(^TMP($JOB,"ACHSDSU",ACHSTY))
SET ^TMP($JOB,"ACHSDSU",ACHSTY)=0
SET X=$GET(^TMP($JOB,"ACHSDSU",ACHSTY))
SET $PIECE(X,U)=$PIECE(X,U)+1
SET $PIECE(X,U,2)=$PIECE(X,U,2)+O
SET ^TMP($JOB,"ACHSDSU",ACHSTY)=X
+8 IF '$DATA(^TMP($JOB,"ACHSDSU",ACHSDEST))
SET ^TMP($JOB,"ACHSDSU",ACHSDEST)=0
+9 SET ^TMP($JOB,"ACHSDSU",ACHSDEST)=$GET(^TMP($JOB,"ACHSDSU",ACHSDEST))+1
+10 GOTO A4
+11 ;
END ; Kill routine vars, print.
+1 KILL ACHSDEST,ACHSDOCR,ACHSTRAN,ACHSTRDT,ACHSTS,ACHSX,ACHSY
+2 ;
DO BRPT^ACHSFU
+3 SET (ACHSACFY,ACHSPG)=0
SET ACHS=""
+4 ;CHECK DATA INTEGRITY HE,HE,HE
DO ^ACHSUF
+5 SET ACHSLOC=$$C^XBFUNC($$LOC^ACHS,80)
SET ACHST1=$$C^XBFUNC($$FMTE^XLFDT(ACHSBDT)_" Thru "_$$FMTE^XLFDT(ACHSEDT))
+6 KILL ACHSSUM
+7 FOR ACHS=1:1:7
SET ACHSSUM(ACHS)=""
+8 SET ACHSACFY=0
+9 USE IO
FY ;
+1 SET ACHSACFY=$ORDER(^TMP($JOB,"ACHSDSU",ACHSACFY))
+2 IF ACHSACFY<1
DO HDR
DO SUM
DO RGSTRS
GOTO KILL
+3 DO HDR
DO HDR1^ACHSODP
+4 SET ACHSACD=""
SET ACHSDIEN=0
SET ACHSDPFX=$EXTRACT(ACHSACFY,4)_"-"_ACHSFC_"-"
CODE ;
+1 SET ACHSACD=$ORDER(^TMP($JOB,"ACHSDSU",ACHSACFY,ACHSACD))
+2 IF ACHSACD=""
DO RTRN^ACHS
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO KILL
GOTO FY
+3 SET ACHSDIEN=0
DOC ;
+1 SET ACHSDIEN=$ORDER(^TMP($JOB,"ACHSDSU",ACHSACFY,ACHSACD,ACHSDIEN))
+2 IF ACHSDIEN<1
GOTO CODE
+3 SET ACHSTN=0
TRANS ;
+1 SET ACHSTN=$ORDER(^TMP($JOB,"ACHSDSU",ACHSACFY,ACHSACD,ACHSDIEN,ACHSTN))
IF ACHSTN<1
GOTO DOC
SET ACHSACS=$GET(^TMP($JOB,"ACHSDSU",ACHSACFY,ACHSACD,ACHSDIEN,ACHSTN))
+2 IF $Y>ACHSBM
DO RTRN^ACHS
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO KILL
DO HDR
DO HDR1^ACHSODP
+3 DO ^ACHSODP1
+4 GOTO TRANS
+5 ;
KILL ;
+1 WRITE @IOF
+2 KILL ZTSK
+3 DO ERPT^ACHS
+4 KILL B,C,DFN,L,N,O,S,T
+5 DO EN^XBVK("ACHS")
IF '$DATA(ZTQUEUED)
DO ^ACHSVAR
+6 QUIT
+7 ;
HDR ;
+1 SET ACHSPG=ACHSPG+1
+2 WRITE @IOF,!,ACHSLOC,!?26,"CHS DOCUMENT SUMMARY REPORT",?71,"Page",$JUSTIFY(ACHSPG,4),!,ACHSTIME,!,ACHST1,!!
+3 QUIT
+4 ;
SUM ;
+1 DO HDR2^ACHSODP
+2 SET ACHSCT=0
SET X2="2$"
SET X3=15
+3 FOR ACHSTYPE="INITIAL","SUPPLEMENTAL","CANCEL","PAYMENT","INTERIM PAYMENT"
Begin DoDot:1
+4 WRITE !?5,ACHSTYPE," DOCUMENTS"
+5 IF $DATA(^TMP($JOB,"ACHSDSU",ACHSTYPE))
SET X=$PIECE(^(ACHSTYPE),U,2)
SET ACHSCT=ACHSCT+X
DO COMMA^%DTC
WRITE ?43,$JUSTIFY($PIECE(^TMP($JOB,"ACHSDSU",ACHSTYPE),U),6),?60,X
+6 QUIT
End DoDot:1
+7 SET X=ACHSCT
+8 DO COMMA^%DTC
+9 WRITE !?43,"________",?62,"_____________",!!?5,"TOTALS",?44,$JUSTIFY(^TMP($JOB,"ACHSDSU","TRAN"),5),?60,X
+10 WRITE !!!?5,"FISCAL AGENT DOCUMENTS:",$SELECT($DATA(^TMP($JOB,"ACHSDSU","FISCAL AGENT")):$JUSTIFY(^("FISCAL AGENT"),5),1:" 0"),!?14,"IHS DOCUMENTS:",$SELECT($DATA(^TMP($JOB,"ACHSDSU","IHS")):$JUSTIFY(^("IHS"),5),1:" 0"),!
+11 DO RTRN^ACHS
+12 QUIT
+13 ;
RGSTRS ;
+1 DO HDR
DO SB2^ACHSODP2
+2 SET ACHSACTN=$SELECT($DATA(^ACHS(9,DUZ(2),"RN")):^("RN"),1:"")
SET X2=2
SET X3=12
+3 FOR ACHS=1:1:7
SET $PIECE(ACHSSUM(ACHS),U,3)=$PIECE(ACHSSUM(ACHS),U)-$PIECE(ACHSSUM(ACHS),U,2)
+4 FOR ACHSX1=1:1:7
WRITE !,$EXTRACT($PIECE(ACHSACTN,U,ACHSX1),1,20),?30
DO SB1
IF ACHSX1<7
WRITE !
+5 WRITE !
+6 DO S21^ACHSODP2
+7 WRITE !,"TOTAL",?30
+8 SET X=0
+9 FOR ACHSX=1,2,3
FOR ACHS=1:1:7
SET X=X+$PIECE(ACHSSUM(ACHS),U,ACHSX)
IF ACHS=7
WRITE $JUSTIFY($FNUMBER(X,",",2),12)
SET ACHSACTO=X
SET X=0
+10 WRITE $JUSTIFY($FNUMBER(ACHSACTO,",",2),12),!!!?1,"Obligated Balance For Period: ",$JUSTIFY("$"_$FNUMBER(ACHSACTO,",",2),14)
+11 KILL ACHSX1,X2
+12 DO RTRN^ACHS
+13 QUIT
+14 ;
SB1 ;
+1 FOR ACHSX=1,2,3,3
WRITE $JUSTIFY($FNUMBER($PIECE(ACHSSUM(ACHSX1),U,ACHSX),",",2),12)
+2 QUIT
+3 ;
