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