Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSBOP

ACHSBOP.m

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