- 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 ;
