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

ACHSUUP.m

Go to the documentation of this file. 
  1. ACHSUUP ; IHS/ITSC/PMF - UPDATE OBLIGATION BALANCE/DCR ACCOUNTS/QUEUE DOCUMENTS ;   [ 02/23/2005  11:39 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,8,9,12**;JUNE 11, 2001
  1.  ;;ITSC/SET/JVK ACHS*3.1*7 ADDED SET OF ESIG TMP GLOBAL
  1.  ;;ITSC/SET/JVK ACHS*3.1*8 ADDED SET OF ESIG TMP GLOBAL
  1.  ;;ITSC/SET/JVK ACHS*3.1*9 FIX UNDEF OF ACHSTTYP
  1.  ;;ITSC/SET/JVK ACHS*3.1*12 FIX ACHSTTYP AFTER PAYMT NO KILLED
  1.  ;
  1.  D CKB,SBA:'$D(ACHSCNC)
  1.  Q
  1.  ;
  1. SBAENT ;EP - Update Current Advice of Allowance and Total Obligated FYTD.
  1. SBA ;
  1.  I '$$LOCK^ACHS("^ACHS(9,DUZ(2))","+") W !,"LOCK OF '^ACHS(9,",DUZ(2),") FAILED AT SBA^ACHSUUP." Q
  1.  ;
  1.  ;'CURRENT ADVICE OF ALLOWANCE'    ;'TOTAL OBLIGATED FYTD'
  1.  S X=$G(^ACHS(9,DUZ(2),"FY",ACHSACFY,0))
  1.  S X1=$P(X,U,2)
  1.  S X2=$P(X,U,3)
  1.  I $D(ACHSISAO) G SBB
  1.  ;
  1.  ;'NEG. UNOBLIGATED BAL. PRIOR FY'?
  1.  I $$PARM^ACHS(2,2)="Y",ACHSACFY<ACHSCFY G SBB
  1.  I ACHSESDO<1 G SBB ; Cancel;IF 'IHS PAYMENT AMOUNT' NOT THERE CANCEL
  1.  ;
  1.  ;IF 'TOTAL OBLIGATED FYTD'+'IHS PAYMENT AMT' IS NOT GREATER THAN
  1.  ;'CURRENT ADVICE OF ALLOWANCE' THEN CONTINUE WE HAVE MONIES
  1.  I (X2+ACHSESDO'>X1) G SBB
  1.  W *7,!,"Funds are not available for this transaction",!,"Transanction Cancelled"
  1.  ;
  1.  ;
  1.  W:ACHSACFY<ACHSCFY !!,"'",$P(^DD(9002080,14.02,0),U),"' parameter = '",$$PARM^ACHS(2,2),"'.",!!
  1.  S ACHSCNC=""
  1.  G SBAEND
  1.  ;
  1. SBB ;
  1.  I ACHS("CHK")>0 G SBAEND
  1.  ;
  1.  ;X IS STILL ^ACHS(9,DUZ(2),"FY",ACHSACFY,0)
  1.  ;ADD 'TOTAL OBLIGATED FYTD' TO 'IHS PAYMENT AMOUNT'
  1.  ;PUT BACK INTO TOTAL OBLIGATED FYTD
  1.  S $P(X,U,3)=$P(X,U,3)+ACHSESDO
  1.  ;
  1.  ;
  1.  S Y=$G(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1)) ;DCR REGISTER BALANCES
  1.  S $P(Y,U,ACHSDCR)=$P(Y,U,ACHSDCR)+ACHSESDO       ;ADD 'IHS PAYMENT AMOUNT TO REGISTER
  1.  S ^ACHS(9,DUZ(2),"FY",ACHSACFY,0)=X              ;
  1.  S ^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1)=Y
  1.  ;
  1.  ;FIELD 8 'TOTAL AMT OBLIGATED'='TOTAL OBLIGATED AMT'+'IHS PAYMENT AMT'
  1.  I '$D(ACHSUFLG),$$DIE^ACHS("8///"_($$DOC^ACHS(0,9)+ACHSESDO))
  1. SBAEND ;
  1.  I '$$LOCK^ACHS("^ACHS(9,DUZ(2))","-") W !,"UNLOCK OF '^ACHS(9,",DUZ(2),") FAILED AT SBAEND^ACHSUUP."
  1.  Q
  1.  ;
  1. SBQ ;EP - Place document in print list.
  1.  ;
  1.  ;QUIT IF HIGH VOLUME PROVIDER 
  1.  Q:$D(^ACHSF(DUZ(2),18,"B",ACHSPROV))
  1.  S ^ACHSF("PQ",DUZ(2),ACHSTYP,ACHSDIEN,ACHSTIEN)=""  ;PLACE IN PRINT QUE
  1.  ;ITSC/SET/JVK ACHS*3.1*7 PLACE IN E-SIG QUE
  1.  ;ITSC/SET/JVK ACHS*3.1*8 1.23.04 -ADD D LOOP PUT IN EQ ONLY INITIAL & SUPPLEMENT
  1.  I $P($G(^ACHSESIG(DUZ(2),0)),U,3)'="",DT>($P($G(^ACHSESIG(DUZ(2),0)),U,3)-1)  D
  1.  .;ITSC/SET/JVK ACHS*3.1*9 3.1.04 - FIX UNDEF OF ACHSTTYP-NO SUPPLEMENTS IN EQ
  1.  .I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)=2 Q
  1.  .I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)'="" Q
  1.  .S ACHSTTYP=""
  1.  .I ACHSTIEN=1 S ACHSTTYP="I"
  1.  .;ITSC/SET/JVK ACHS*3.1*12 12/21/04 CHECK PATTERN MATCH TO BE ALPHA
  1.  .I ACHSTTYP'?1A.A S ACHSTTYP=$P(ACHSTRAN,U,2)
  1.  .I ACHSTTYP'?1A.A,ACHSTRAN="" S ACHSTTYP=$P(T,U,2)
  1.  .I ACHSTTYP="I" S ^ACHSF("EQ",DUZ(2),ACHSTYP,ACHSDIEN,ACHSTIEN)=""
  1.  .I ACHSTTYP="S",'$D(^ACHSF("EQ",DUZ(2),ACHSTYP,ACHSDIEN)) S ^ACHSF("EQ",DUZ(2),ACHSTYP,ACHSDIEN,ACHSTIEN)=""
  1.  .;I '$D(^ACHSF("EQ",DUZ(2),ACHSTYP,ACHSDIEN)) S ^JVKTMP=ACHSDIEN_U_ACHSTTYP_U_ACHSTRAN_U_ACHSTIEN
  1.  .Q
  1.  ;ITSC/SET/JVK ACHS*3.1*12 12/21/04 KILL THE TRANSACTION TYPE
  1.  K ACHSTTYP
  1.  Q
  1.  ;
  1. AVAIL(A,Y,C) ;EP - Check if money "A" available for transaction in year "Y", "C" is current FY. 1=Yes, 0=No.
  1.  I $D(ACHSISAO) Q 1  ; Auto processing of EOBRs.
  1.  I $$PARM^ACHS(2,2)="Y",Y<C Q 1  ; Previous FY, parm sez OK.
  1.  I A<1 Q 1  ; Cancellation
  1.  N M,N
  1.  S X=$G(^ACHS(9,DUZ(2),"FY",Y,0))      ;GET FISCAL YEAR 0 NODE
  1.  S M=$P(X,U,2)                         ;'CURRENT ADVICE OF ALLOWANCE'
  1.  S N=$P(X,U,3)                         ;'TOTAL OBLIGATED FYTD'
  1.  I (N+A'>M) Q 1
  1.  Q 0
  1.  ;
  1. CKB ;EP - CK for "OUT-OF-BALANCE" condition.
  1.  ; 
  1.  ; The sum of fields DCR-(1 thru 7) BALANCE of the current
  1.  ; register must equal the TOTAL OBLIGATED FYTD field in
  1.  ; the Fiscal Year in use.
  1.  ;
  1.  K ACHSCNC
  1.  S ACHS("BALC")=0
  1.  ;
  1.  F I=1:1:7 D     ;ADD UP DCR BALANCES
  1.  .S ACHS("BALC")=ACHS("BALC")+$P(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1),U,I)
  1.  ;IF TOTAL DCR BALANCES EQUAL TOTAL OBLIGATED FYTD OKAY
  1.  I ACHS("BALC")=$P(^ACHS(9,DUZ(2),"FY",ACHSACFY,0),U,3) K ACHS("BALC") Q
  1.  ;
  1.  S ACHSCNC=1                    ;CANCEL FLAG
  1.  Q:$D(ACHSISAO)                 ;IS AREA OFFICE?
  1.  D VIDEO^ACHS                   ;SET REVERSE VIDEO VARIABLES
  1.  S ACHS=$$REPEAT^XLFSTR("*",79)
  1.  W *7,!!!!,ACHS,!!,ACHS,!!!?22,$G(IORVON),"THE REGISTERS ARE OUT OF BALANCE",$G(IORVOFF),!!?26,$G(IORVON),"CONTACT YOUR SITE MANAGER",$G(IORVOFF),!!!,ACHS,!!,ACHS,!
  1.  D RTRN^ACHS            ;PRESS RETURN TO CONTINUE
  1.  I $D(^XUSEC("ACHSZMGR",DUZ)),$$DIR^XBDIR("Y","Want me to fix it for you","N","","","^D HELP^ACHSUUP",1) D FIX^ACHSBRF(ACHSACFY,ACHSACWK),RTRN^ACHS G CKB
  1.  Q
  1.  ;
  1. HELP ;EP - From DIR.
  1.  F %=2:1 W !?5,$P($T(HELP+%),";",3) Q:$P($T(HELP+%+1),";",3)=""
  1.  ;;If you answer YES, the account balances and YTD oblligated will be
  1.  ;;calculated from the existing documents, and the CHS DATA CONTROL
  1.  ;;FILE will be updated accordingly.
  1.  Q
  1.  ;