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

ACHSA.m

Go to the documentation of this file. 
  1. ACHSA ; IHS/ITSC/PMF - ENTER DOCUMENTS (1/8)-(FY,TOS) ;     [ 10/16/2001   8:16 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
  1.  ;
  1.  ; ACHSAFLG flags whether the user is confirming/re-entering data
  1.  ; for the current document.I.e., answered "NO" to 'everything correct'.
  1.  ;
  1.  ;CALLED FROM RTN ACHSAI
  1.  ;
  1.  ;I HATE doing this, but for right now, it's the only answer.
  1.  ;Somehow the user finds a way to enter here so that the basic
  1.  ;vars don't get set.  So we will check for the current fiscal
  1.  ;year and if it is not set, we gonna set it along with the
  1.  ;financial code.   2/28/01   pmf
  1.  I '$D(ACHSCFY) D FY^ACHSUF,FC^ACHSUF,^ACHSVAR
  1.  I $G(ACHSFYWK(DUZ(2),ACHSCFY))="" D FY^ACHSUF,FC^ACHSUF,^ACHSVAR
  1.  ;
  1.  S ACHSACFY=ACHSCFY,ACHSAFLG=""
  1.  ;
  1.  ;Once the registers are closed, do NOT create a new PO
  1.  ;until tomorrow.  022801   pmf
  1.  ;
  1.  ;
  1.  I $P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",+ACHSFYWK(DUZ(2),ACHSCFY),0)),U,2)=DT W !!,*7,"  The Register Has Been CLOSED." S DUOUT=$$DIR^XBDIR("E","Press RETURN...") D END Q
  1.  ;
  1.  ;
  1. A1A ;EP.
  1.  ;
  1.  I $D(ACHSOUT) K ACHSOUT D END Q
  1.  ;
  1.  ;ACHSAFLG IS SET IN ACHSA7
  1.  ;ACHSA7+13    IF "Is this correct?" prompt is answered "NO"
  1.  ;ACHSA7+18    IF funds not available 
  1.  I '$G(ACHSAFLG) S ACHSACFY=ACHSCFY
  1.  E  W !,"CONFIRM / RE-ENTER DATA..." I ACHSACFY'=ACHSCFY W !,"NOTE PRIOR FY!.",!
  1.  ;
  1.  ;IF NOT BLANKET AND NOT SPECIAL OBLIG. AND LINK TO REFERRAL SYSTEM
  1.  ;IS ON
  1.  I '$D(ACHSBLKF),'$D(ACHSSLOC),$$LINK^ACHSBMC S ACHSREF=$G(ACHSREF) D GETREF^ACHSBMC(.ACHSREF) I $D(DUOUT)!$D(DTOUT) D END Q
  1.  ;
  1. FY ; Select FY.
  1.  S ACHSACFY=$$FYSEL^ACHS(1)
  1.  I $D(DTOUT)!$D(DUOUT) D END Q
  1.  I '$D(^ACHS(9,DUZ(2),"FY",ACHSACFY)) W !!,*7,"Fiscal year '",ACHSACFY,"' does not exist. -- TRY AGAIN" G FY
  1.  I ACHSACFY<ACHSCFY W *7 I '$$DIR^XBDIR("Y","Are you sure you want to issue document for a PRIOR FISCAL YEAR","NO","","","",2) G FY
  1. A1C ;
  1.  S ACHSACWK=+ACHSFYWK(DUZ(2),ACHSACFY)
  1.  ;
  1.  D CKB^ACHSUUP                         ;CHECK DCR BALANCES
  1.  ;
  1.  ;IF OUT OF BALANCE QUIT
  1.  I $D(ACHSCNC) S DUOUT=$$DIR^XBDIR("E","Press RETURN...","","","","",1) Q
  1.  ;ASK FOR TYPE OF SERVICE
  1. A3 ;EP.
  1.  S Y=$G(ACHSTYP)
  1.  I Y S Y=$S(Y=1:"Hospital Service",Y=2:"Dental Service",Y=3:"Outpatient Service",1:"")
  1.  S Y=$$DIR^XBDIR("S^43:Hospital Service;57:Dental Service;64:Outpatient Service","Type Of Service",Y,"","","",1)
  1.  G A1A:$D(DUOUT)
  1.  I $D(DTOUT)!('Y) D END Q
  1.  S ACHSTYP=$S(Y=43:1,Y=57:2,Y=64:3,1:"")
  1.  ;
  1.  D ^ACHSA1                          ;DO ENTER DOCUMENT RTN 2 OF 8
  1.  ;
  1.  Q
  1. END ;EP - For fast-out (ACHSQUIT) of initial document.
  1.  K %DT,I,M,P,R,S,Z
  1.  D EN^XBVK("ACHS"),^ACHSVAR
  1.  Q
  1.  ;