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

ACHSPCC1.m

Go to the documentation of this file. 
  1. ACHSPCC1 ; IHS/ITSC/TPF/PMF - CHS AREA SPLITOUT (1/5) ; JUL 10, 2008
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,21**;JUN 11,2001;Build 43
  1.  ;ACHS*3.1*14 IHS/OIT/FCJ call new routine for printing UFMS and FI totals
  1.  ;
  1.  D HOME^%ZIS
  1.  S ACHSIO=IO
  1.  I $D(^ACHSPCC("ODF-POST")) D  Q
  1.  . U IO(0)
  1.  . W !?10,"CHS FACILITY FILES ALREADY PROCESSED ON ",$$FMTE^XLFDT($P(^ACHSPCC("ODF-POST"),U,1)),!!?10,"JOB CANCELLED"
  1.  . D JOBABEND^ACHSPCC4
  1.  .Q
  1.  S X=$P(^AUTTLOC(DUZ(2),0),U,4),ACHSPFX=$P(^AUTTAREA(X,0),U,4),ACHSAREA=$P(^(0),U)
  1.  S ACHSAPN=$P(^AUTTSITE(1,0),U,2)
  1.  I ACHSAPN']"" D  Q
  1.  . W *7,!,"ACCOUNTING POINT NUMBER is missing from RPMS SITE file...",!
  1.  . D JOBABEND^ACHSPCC4
  1.  .Q
  1.  S X=$O(^AUTTTEL(DUZ(2),1,"B","PCC",""))
  1.  I +X<1 D ERR("PCC") Q
  1.  S ACHSPRN=$P(^AUTTTEL(DUZ(2),1,X,0),U,2)
  1.  I +ACHSPRN<1 D ERR("RJEPCC") Q
  1.  I '$D(^AUTTTEL(DUZ(2),1,"B","BCS")) D ERR("BCS") Q
  1.  S X=$O(^AUTTTEL(DUZ(2),1,"B","BCS",""))
  1.  I '$D(^AUTTTEL(DUZ(2),1,X,0)) D ERR("BCS") Q
  1.  S ACHSFIRN=$P(^AUTTTEL(DUZ(2),1,X,0),U,2)
  1.  I +ACHSFIRN<1 D ERR("RJEBCS") Q
  1.  I +ACHSPFX>0,(+ACHSPFX<300!(+ACHSPFX>399)) D CPFXERR Q
  1.  I +ACHSPFX=0,$E(ACHSPFX)'="J" D CPFXERR Q
  1.  I $L(ACHSPFX)'=3 D CPFXERR Q
  1.  W !,$$C^XBFUNC("AREA PREFIX="_$E(ACHSPFX,2,3)),!
  1.  U IO(0)
  1.  ;ACHS*3.1*21 CHANGED HAS/CORE TO UFMS
  1.  ;W !,"Your CHS FACILITY DHR Transactions Should be TRANSMITTED to:",!?10,"(1) HAS and/or CORE",!?10,$S($$AOP^ACHS(2,8)="Y":"(2) Fiscal Intermediary",1:" ")
  1.  W !,"Your CHS FACILITY DHR Transactions Should be TRANSMITTED to:"
  1.  W !?10,"(1) United Finacial Management System for Federal Facilities"
  1.  W !?10,$S($$AOP^ACHS(2,3)="Y":"(2) Fiscal Intermediary",1:" ")
  1.  U IO(0)
  1.  I '$$DIR^XBDIR("E","","","","","",2) D JOBABEND^ACHSPCC4 Q
  1.  I $D(DUOUT)!$D(DTOUT) D JOBABEND^ACHSPCC4 Q
  1. EFFD ;
  1.  S ACHSEFDT=$$DIR^XBDIR("D","Enter Effective Transaction Date ",$$FMTE^XLFDT(DT),"","The effective date will be placed in all DHR records","^S Y=""??"",%DT=""E"" D ^%DT",2)
  1.  I $D(DTOUT)!$D(DUOUT)!(ACHSEFDT<1) D JOBABEND^ACHSPCC4 Q
  1.  I ACHSEFDT>DT W *7," CAN'T BE FUTURE DATE" G EFFD
  1.  S ACHSEFDT=$E(Y,4,7)_$E(Y,2,3)
  1.  W !
  1.  S %ZIS("A")="ENTER DEVICE # FOR SUMMARY REPORT ",%ZIS="P"
  1.  D ^%ZIS
  1.  K %ZIS
  1.  I POP D HOME^%ZIS D JOBABEND^ACHSPCC4 Q
  1.  S ACHSPTRD=IO,ACHSCCTR="PCC"
  1.  ;ACHS*3.1*14 11/15/2007 IHS/OIT/FCJ REMOVED CALL TO ACHSPCC2 AND NOW CALLING ACHSPCCR
  1.  ;D ^ACHSPCC2
  1.  S ACHSCT2=0,ACHSHASH=0 D ^ACHSPCCR
  1.  Q:$D(ACHSFLG)
  1.  D ^ACHSPCC3
  1.  Q
  1.  ;
  1. CPFXERR ;
  1.  W *7,!!?12," CAN NUMBER PREFIX NOT CORRECTLY DEFINED FOR THIS FACILITY",!,"PREFIX = '",ACHSPFX,"'",!!?35,"JOB CANCELLED",!!
  1.  D ENTRETRN^ACHSPCC4
  1.  Q
  1.  ;
  1. PCC ;;COMPUTER CENTER entry Missing for ITS (Parklawn)
  1. RJEPCC ;;Default RJE # for ITS (Parklawn) Missing
  1. BCS ;;COMPUTER CENTER entry Missing for the Fiscal Intemediary
  1. RJEBCS ;;Default RJE # for the Fiscal Intemediary Missing
  1. ERR(X) ;
  1.  W *7,!!?10,$P($T(@X),";",3)
  1.  W !?10,"In IHS COMMUNICATIONS PARAMETERS file for ",$$LOC^ACHS
  1.  D JOBABEND^ACHSPCC4
  1.  Q
  1.  ;