ACHSBOP ; IHS/ITSC/PMF - PRINT/DISPLAY REGISTER BALANCES ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
S ACHSIO=IO,%ZIS="P"
D ^%ZIS,SLV^ACHSFU:$D(IO("S"))
I POP D HAT Q
;
A1A ;EP - From option to display balances.
K X2,X3
U IO(0)
X:$D(IO("S")) ACHSPPC ;IF SLAVE OPEN SLAVE
FY ;
S ACHSACFY=$$FYSEL^ACHS ;SELECT A DEFINED FISCAL YEAR
I $D(DUOUT)!$D(DTOUT) D HAT Q
;
I '$D(^ACHS(9,DUZ(2),"FY",+Y))!'$D(ACHSFYWK(DUZ(2),+Y)) W !!,*7,"FY '",+Y,"' does not exist for this facility." G A1A
S ACHSACWK=+ACHSFYWK(DUZ(2),ACHSACFY)
;
D CKB^ACHSUUP ;CHECK BALANCES
D NOW^ACHS ;SET ACHSTIME=CURRENT TIME
;
A1 ;
U IO
X:$D(IO("S")) ACHSPPO ;
W @IOF,!,$$C^XBFUNC($$LOC^ACHS),!,$$C^XBFUNC("CHS REGISTER BALANCES"),!?80-$L(ACHSTIME)/2,ACHSTIME
S (S,B,W)=""
S ACHSRGNM=$S($D(^ACHS(9,DUZ(2),"RN")):^ACHS(9,DUZ(2),"RN"),1:"") ;'R-1 NAME' ?????
S X3=16
I '$D(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1)),+ACHS("ZL")=DT S ACHSACWK=ACHSACWK-1
;
;GET FISCAL YEAR 0 NODE
S S=$G(^ACHS(9,DUZ(2),"FY",ACHSACFY,0))
;
;GET FISCAL YEAR 1 NODE ('INITIAL REG-1')
S B=$G(^ACHS(9,DUZ(2),"FY",ACHSACFY,1))
;
S W=$G(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1))
S F=0
F I=1:1:7 I $P(B,U,I) S F=1 Q ;IF ANY 'INITAL REG-I' IS SET
A2 ;
;
D SBH ;PRINT SUB HEADER
;
F K=1:1:7 D SBD ;PRINT DETAIL LINE
I 'F W ?48,"Un-Obligated Balance"
;
;PRINT BOTTOM SUMMARY
W !
I F W ?18,"---------------",?35,"----------------",?57,"----------------"
E W ?26,"----------------"
W !,"TOTAL"
I F S X2="2$",X=$P(S,U,2) D COMMA^%DTC W ?18,X S X=$P(S,U,3) D COMMA^%DTC W ?35,X S X=$P(S,U,2)-$P(S,U,3) D COMMA^%DTC W ?57,X I 1
E S X=$P(S,U,3) D COMMA^%DTC W ?27,X S X=$P(S,U,2)-$P(S,U,3) D COMMA^%DTC W ?50,X
B1 ;
I $D(ACHSCNC) W !,"**** THE REGISTERS ARE OUT OF BALANCE!" ;CANCEL FLAG
D RTRN^ACHS ;PRESS RETURN TO CONT.
I ACHSIO=IO&'$D(IO("S")) D END Q
W @IOF
B2 ;
U IO(0)
X:$D(IO("S")) ACHSPPC ;IF SLAVE CLOSE SALVE
I $$DIR^XBDIR("Y","Do You Wish To Print Another Copy ","NO","","","",2) G A1
END ;
I '$D(ZTQUEUED),ACHSIO=IO,'$D(IO("S")) D INITIALS^ACHSALUP(ACHSACFY)
HAT ;
D EN^XBVK("ACHS"),^ACHSVAR
K B,C,D,F,I,J,K,N,S,W,X,X2,X3,Y
D ^%ZISC
Q
;
SBD ;
W !?1,$P(ACHSRGNM,U,K)
I F S X=$P(B,U,K) D COMMA^%DTC W ?18,X S X=$P(W,U,K) D COMMA^%DTC W ?35,X S X=$P(B,U,K)-$P(W,U,K) D COMMA^%DTC W ?57,X I 1
E S X=$P(W,U,K) D COMMA^%DTC W ?27,X
Q
;
SBH ;
W !!!?12,"Fiscal Year ",ACHSACFY,?44,"Register Number ",$E(ACHSACFY,4),"-",$E(1000+ACHSACWK,2,4),!
S ACHSACN=""
I $D(^ACHS(9,DUZ(2),"FY",ACHSACFY,"C")) D
.S ACHSACN=+^ACHS(9,DUZ(2),"FY",ACHSACFY,"C")
.S ACHSACN=$E("00000",1,5-$L(ACHSACN))_ACHSACN
.S ACHSACN=$E(ACHSACFY,4)_"-"_ACHSFC_"-"_ACHSACN
W !,"Last document issued: ",ACHSACN,?44,"Advice of Allow: "
S X=$S($D(^ACHS(9,DUZ(2),"FY",ACHSACFY,0))#2:$P($G(^ACHS(9,DUZ(2),"FY",ACHSACFY,0)),U,2),1:"") D COMMA^%DTC W ?63,X,!
W !?1,"Register"
I F W ?18,"Initial Balance",?35,"Obligated Amount",?57,"Current Balance"
E W ?26,"Obligated Amount"
W !?1,"---------" I W ?18,"---------------",?35,"----------------",?57,"----------------"
E W ?26,"----------------"
Q
;
ACHSBOP ; IHS/ITSC/PMF - PRINT/DISPLAY REGISTER BALANCES ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 SET ACHSIO=IO
SET %ZIS="P"
+4 DO ^%ZIS
IF $DATA(IO("S"))
DO SLV^ACHSFU
+5 IF POP
DO HAT
QUIT
+6 ;
A1A ;EP - From option to display balances.
+1 KILL X2,X3
+2 USE IO(0)
+3 ;IF SLAVE OPEN SLAVE
IF $DATA(IO("S"))
XECUTE ACHSPPC
FY ;
+1 ;SELECT A DEFINED FISCAL YEAR
SET ACHSACFY=$$FYSEL^ACHS
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
DO HAT
QUIT
+3 ;
+4 IF '$DATA(^ACHS(9,DUZ(2),"FY",+Y))!'$DATA(ACHSFYWK(DUZ(2),+Y))
WRITE !!,*7,"FY '",+Y,"' does not exist for this facility."
GOTO A1A
+5 SET ACHSACWK=+ACHSFYWK(DUZ(2),ACHSACFY)
+6 ;
+7 ;CHECK BALANCES
DO CKB^ACHSUUP
+8 ;SET ACHSTIME=CURRENT TIME
DO NOW^ACHS
+9 ;
A1 ;
+1 USE IO
+2 ;
IF $DATA(IO("S"))
XECUTE ACHSPPO
+3 WRITE @IOF,!,$$C^XBFUNC($$LOC^ACHS),!,$$C^XBFUNC("CHS REGISTER BALANCES"),!?80-$LENGTH(ACHSTIME)/2,ACHSTIME
+4 SET (S,B,W)=""
+5 ;'R-1 NAME' ?????
SET ACHSRGNM=$SELECT($DATA(^ACHS(9,DUZ(2),"RN")):^ACHS(9,DUZ(2),"RN"),1:"")
+6 SET X3=16
+7 IF '$DATA(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1))
IF +ACHS("ZL")=DT
SET ACHSACWK=ACHSACWK-1
+8 ;
+9 ;GET FISCAL YEAR 0 NODE
+10 SET S=$GET(^ACHS(9,DUZ(2),"FY",ACHSACFY,0))
+11 ;
+12 ;GET FISCAL YEAR 1 NODE ('INITIAL REG-1')
+13 SET B=$GET(^ACHS(9,DUZ(2),"FY",ACHSACFY,1))
+14 ;
+15 SET W=$GET(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1))
+16 SET F=0
+17 ;IF ANY 'INITAL REG-I' IS SET
FOR I=1:1:7
IF $PIECE(B,U,I)
SET F=1
QUIT
A2 ;
+1 ;
+2 ;PRINT SUB HEADER
DO SBH
+3 ;
+4 ;PRINT DETAIL LINE
FOR K=1:1:7
DO SBD
+5 IF 'F
WRITE ?48,"Un-Obligated Balance"
+6 ;
+7 ;PRINT BOTTOM SUMMARY
+8 WRITE !
+9 IF F
WRITE ?18,"---------------",?35,"----------------",?57,"----------------"
+10 IF '$TEST
WRITE ?26,"----------------"
+11 WRITE !,"TOTAL"
+12 IF F
SET X2="2$"
SET X=$PIECE(S,U,2)
DO COMMA^%DTC
WRITE ?18,X
SET X=$PIECE(S,U,3)
DO COMMA^%DTC
WRITE ?35,X
SET X=$PIECE(S,U,2)-$PIECE(S,U,3)
DO COMMA^%DTC
WRITE ?57,X
IF 1
+13 IF '$TEST
SET X=$PIECE(S,U,3)
DO COMMA^%DTC
WRITE ?27,X
SET X=$PIECE(S,U,2)-$PIECE(S,U,3)
DO COMMA^%DTC
WRITE ?50,X
B1 ;
+1 ;CANCEL FLAG
IF $DATA(ACHSCNC)
WRITE !,"**** THE REGISTERS ARE OUT OF BALANCE!"
+2 ;PRESS RETURN TO CONT.
DO RTRN^ACHS
+3 IF ACHSIO=IO&'$DATA(IO("S"))
DO END
QUIT
+4 WRITE @IOF
B2 ;
+1 USE IO(0)
+2 ;IF SLAVE CLOSE SALVE
IF $DATA(IO("S"))
XECUTE ACHSPPC
+3 IF $$DIR^XBDIR("Y","Do You Wish To Print Another Copy ","NO","","","",2)
GOTO A1
END ;
+1 IF '$DATA(ZTQUEUED)
IF ACHSIO=IO
IF '$DATA(IO("S"))
DO INITIALS^ACHSALUP(ACHSACFY)
HAT ;
+1 DO EN^XBVK("ACHS")
DO ^ACHSVAR
+2 KILL B,C,D,F,I,J,K,N,S,W,X,X2,X3,Y
+3 DO ^%ZISC
+4 QUIT
+5 ;
SBD ;
+1 WRITE !?1,$PIECE(ACHSRGNM,U,K)
+2 IF F
SET X=$PIECE(B,U,K)
DO COMMA^%DTC
WRITE ?18,X
SET X=$PIECE(W,U,K)
DO COMMA^%DTC
WRITE ?35,X
SET X=$PIECE(B,U,K)-$PIECE(W,U,K)
DO COMMA^%DTC
WRITE ?57,X
IF 1
+3 IF '$TEST
SET X=$PIECE(W,U,K)
DO COMMA^%DTC
WRITE ?27,X
+4 QUIT
+5 ;
SBH ;
+1 WRITE !!!?12,"Fiscal Year ",ACHSACFY,?44,"Register Number ",$EXTRACT(ACHSACFY,4),"-",$EXTRACT(1000+ACHSACWK,2,4),!
+2 SET ACHSACN=""
+3 IF $DATA(^ACHS(9,DUZ(2),"FY",ACHSACFY,"C"))
Begin DoDot:1
+4 SET ACHSACN=+^ACHS(9,DUZ(2),"FY",ACHSACFY,"C")
+5 SET ACHSACN=$EXTRACT("00000",1,5-$LENGTH(ACHSACN))_ACHSACN
+6 SET ACHSACN=$EXTRACT(ACHSACFY,4)_"-"_ACHSFC_"-"_ACHSACN
End DoDot:1
+7 WRITE !,"Last document issued: ",ACHSACN,?44,"Advice of Allow: "
+8 SET X=$SELECT($DATA(^ACHS(9,DUZ(2),"FY",ACHSACFY,0))#2:$PIECE($GET(^ACHS(9,DUZ(2),"FY",ACHSACFY,0)),U,2),1:"")
DO COMMA^%DTC
WRITE ?63,X,!
+9 WRITE !?1,"Register"
+10 IF F
WRITE ?18,"Initial Balance",?35,"Obligated Amount",?57,"Current Balance"
+11 IF '$TEST
WRITE ?26,"Obligated Amount"
+12 WRITE !?1,"---------"
IF $TEST
WRITE ?18,"---------------",?35,"----------------",?57,"----------------"
+13 IF '$TEST
WRITE ?26,"----------------"
+14 QUIT
+15 ;
