ACHSODP2 ; IHS/ITSC/PMF - PRINT DCR REPORT (3/3) ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
D SB2 ;PRINT COLUMN HEADINGS
;
S ACHSACTN=$G(^ACHS(9,DUZ(2),"RN")) ;'R-1 NAME'
S X2=2,X3=12,ACHSOUT=0,ACHSBBAL=""
I ACHSREG>1,$D(^ACHS(9,DUZ(2),"FY",ACHSFYY,"W",ACHSREG-1,1)) S ACHSBBAL=$G(^ACHS(9,DUZ(2),"FY",ACHSFYY,"W",ACHSREG-1,1))
;
;
F %=1:1:7 S $P(ACHSSUM(%),U,3)=$P(ACHSSUM(%),U)-$P(ACHSSUM(%),U,2)
F K=1:1:7 W !,$E($P(ACHSACTN,U,K),1,18),?18 D SB1 W:K<7 !
;
W !
D S21 ;UNDERLINE COLUMN HEADINGS
W !,"TOTAL",?18
S X=0 F %=1:1:7 S X=X+$P(ACHSBBAL,U,%)
;
D FMT ;FORMAT DOLLAR AMTS
;
F ACHSX=1,2,3 F I=1:1:7 S X=X+$P(ACHSSUM(I),U,ACHSX) D:I=7 FMT
;
S ACHSEBAL=""
F %=1:1:7 S Y=$P(ACHSBBAL,U,%)+$P(ACHSSUM(%),U,3),X=X+Y,ACHSEBAL=ACHSEBAL_Y_"^",ACHSACTO=X
;
D FMT ;FORMAT DOLLAR AMTS
;
S ACHSCHSS="V"
D:'$D(ACHS("DCR")) ^ACHSUF ;CHS FACILITY VARS, CHECK DATA INTEGRITY
;
S ACHSEBCK=$G(^ACHS(9,DUZ(2),"FY",ACHSFYY,"W",ACHSREG,1))
;
F %=1:1:7 I +$P(ACHSEBAL,U,%)'=+$P(ACHSEBCK,U,%) W !!!!?15,"***** SYSTEM OUT OF BALANCE ***** DCR ACCOUNT# ",%," ********" S ACHSOUT=2
I ACHSREG=+(ACHSFYWK(DUZ(2),$S($D(ACHS("DCR")):ACHSCFY-1,1:ACHSCFY))) S ACHSACWK=ACHSREG,ACHSACFY=ACHSFYY D CKB^ACHSUUP G END:$D(ACHSCNC)
;
S X2="2$",X3=18
S X=$P(^ACHS(9,DUZ(2),"FY",ACHSFYY,0),U,2) ;'CURRENT ADVICE OF ALLOWANCE
S ACHSACT1=X
D COMMA^%DTC
;
W !!!!!?2,"Year to Date Allowance:",X,!?7,"Obligated Balance:" S X=ACHSACTO D COMMA^%DTC W X,!?27,"----------------",!?5,"Unobligated Balance:"
;
S X=$J(ACHSACT1-ACHSACTO,1,2)
D FMT
END ; Ask RTRN, write IOF, kill vars, quit.
D RTRN^ACHS
W @IOF
K ACHSBBAL,ACHSEBAL,ACHSEBCK,X2,X3
Q
;
SB1 ;
S X=$P(ACHSBBAL,U,K)
D FMT
F ACHSX=1,2,3 S X=$P(ACHSSUM(K),U,ACHSX) D FMT
S X=$P(ACHSBBAL,U,K)+$P(ACHSSUM(K),U,3)
D FMT
Q
;
FMT ;EP.
I '+X,'+$P(X,".",2) S X=$J("",X3) W X S X=0 Q
D COMMA^%DTC
W X
S X=0
Q
;
SB2 ;EP - Column headers.
W !!?4,"Register",?20,"Beginning",?32,"Increased",?45,"Decreased",?58,"Net",?71,"Ending",!?21,"Balance",?34,"Amount",?46,"Amount",?59,"Change",?71,"Balance",!,"----------------"
S21 ;EP - Underline column headers.
W ?18,"------------",?32,"----------",?44,"----------",?56,"----------",?68,"-----------"
Q
;
ACHSODP2 ; IHS/ITSC/PMF - PRINT DCR REPORT (3/3) ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 ;PRINT COLUMN HEADINGS
DO SB2
+4 ;
+5 ;'R-1 NAME'
SET ACHSACTN=$GET(^ACHS(9,DUZ(2),"RN"))
+6 SET X2=2
SET X3=12
SET ACHSOUT=0
SET ACHSBBAL=""
+7 IF ACHSREG>1
IF $DATA(^ACHS(9,DUZ(2),"FY",ACHSFYY,"W",ACHSREG-1,1))
SET ACHSBBAL=$GET(^ACHS(9,DUZ(2),"FY",ACHSFYY,"W",ACHSREG-1,1))
+8 ;
+9 ;
+10 FOR %=1:1:7
SET $PIECE(ACHSSUM(%),U,3)=$PIECE(ACHSSUM(%),U)-$PIECE(ACHSSUM(%),U,2)
+11 FOR K=1:1:7
WRITE !,$EXTRACT($PIECE(ACHSACTN,U,K),1,18),?18
DO SB1
IF K<7
WRITE !
+12 ;
+13 WRITE !
+14 ;UNDERLINE COLUMN HEADINGS
DO S21
+15 WRITE !,"TOTAL",?18
+16 SET X=0
FOR %=1:1:7
SET X=X+$PIECE(ACHSBBAL,U,%)
+17 ;
+18 ;FORMAT DOLLAR AMTS
DO FMT
+19 ;
+20 FOR ACHSX=1,2,3
FOR I=1:1:7
SET X=X+$PIECE(ACHSSUM(I),U,ACHSX)
IF I=7
DO FMT
+21 ;
+22 SET ACHSEBAL=""
+23 FOR %=1:1:7
SET Y=$PIECE(ACHSBBAL,U,%)+$PIECE(ACHSSUM(%),U,3)
SET X=X+Y
SET ACHSEBAL=ACHSEBAL_Y_"^"
SET ACHSACTO=X
+24 ;
+25 ;FORMAT DOLLAR AMTS
DO FMT
+26 ;
+27 SET ACHSCHSS="V"
+28 ;CHS FACILITY VARS, CHECK DATA INTEGRITY
IF '$DATA(ACHS("DCR"))
DO ^ACHSUF
+29 ;
+30 SET ACHSEBCK=$GET(^ACHS(9,DUZ(2),"FY",ACHSFYY,"W",ACHSREG,1))
+31 ;
+32 FOR %=1:1:7
IF +$PIECE(ACHSEBAL,U,%)'=+$PIECE(ACHSEBCK,U,%)
WRITE !!!!?15,"***** SYSTEM OUT OF BALANCE ***** DCR ACCOUNT# ",%," ********"
SET ACHSOUT=2
+33 IF ACHSREG=+(ACHSFYWK(DUZ(2),$SELECT($DATA(ACHS("DCR")):ACHSCFY-1,1:ACHSCFY)))
SET ACHSACWK=ACHSREG
SET ACHSACFY=ACHSFYY
DO CKB^ACHSUUP
IF $DATA(ACHSCNC)
GOTO END
+34 ;
+35 SET X2="2$"
SET X3=18
+36 ;'CURRENT ADVICE OF ALLOWANCE
SET X=$PIECE(^ACHS(9,DUZ(2),"FY",ACHSFYY,0),U,2)
+37 SET ACHSACT1=X
+38 DO COMMA^%DTC
+39 ;
+40 WRITE !!!!!?2,"Year to Date Allowance:",X,!?7,"Obligated Balance:"
SET X=ACHSACTO
DO COMMA^%DTC
WRITE X,!?27,"----------------",!?5,"Unobligated Balance:"
+41 ;
+42 SET X=$JUSTIFY(ACHSACT1-ACHSACTO,1,2)
+43 DO FMT
END ; Ask RTRN, write IOF, kill vars, quit.
+1 DO RTRN^ACHS
+2 WRITE @IOF
+3 KILL ACHSBBAL,ACHSEBAL,ACHSEBCK,X2,X3
+4 QUIT
+5 ;
SB1 ;
+1 SET X=$PIECE(ACHSBBAL,U,K)
+2 DO FMT
+3 FOR ACHSX=1,2,3
SET X=$PIECE(ACHSSUM(K),U,ACHSX)
DO FMT
+4 SET X=$PIECE(ACHSBBAL,U,K)+$PIECE(ACHSSUM(K),U,3)
+5 DO FMT
+6 QUIT
+7 ;
FMT ;EP.
+1 IF '+X
IF '+$PIECE(X,".",2)
SET X=$JUSTIFY("",X3)
WRITE X
SET X=0
QUIT
+2 DO COMMA^%DTC
+3 WRITE X
+4 SET X=0
+5 QUIT
+6 ;
SB2 ;EP - Column headers.
+1 WRITE !!?4,"Register",?20,"Beginning",?32,"Increased",?45,"Decreased",?58,"Net",?71,"Ending",!?21,"Balance",?34,"Amount",?46,"Amount",?59,"Change",?71,"Balance",!,"----------------"
S21 ;EP - Underline column headers.
+1 WRITE ?18,"------------",?32,"----------",?44,"----------",?56,"----------",?68,"-----------"
+2 QUIT
+3 ;
