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

ACHSACO2.m

Go to the documentation of this file. 
  1. ACHSACO2 ; IHS/ITSC/TPF/PMF - AREA CONSOLIDATION (3/3) PLACE ENTRY INTO THE CHS AO PROCESSING LOG ;JUL 10, 2008
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,14,19,23**;JUN 11,2001;Build 43
  1.  ;ACHS*3.1*13 6.14.2007 IHS/OIT/FCJ ADDED "U" TYPE RECORDS AND MOFIFIED DISPLAY ON TOTALS
  1.  ;ACHS*3.1*14 9.12.2007 IHS/OIT/FCJ FX SETTING FI "AA" RECORD
  1.  ;
  1. END ;EP.
  1.  U IO(0)
  1.  W !!?10,"T Y P E   O F   D A T A",?45,"# TRANSFERRED",!!
  1.  S ACHSOK=1,ACHSTOTL=0
  1.  F ACHSY=2:1:7,"U" D  ;ACHS*3.1*13 IHS/OIT/FCJ ADDED "U" TYPE RECORD 
  1.  .S ACHSTOTL=ACHSTOTL+ACHSTOTL(ACHSY)
  1.  .I ACHSY="U" W ?7,"8.",?10,$$REC^ACHSACO1(8),?50,$J(ACHSTOTL(ACHSY),6),! Q  ;ACHS*3.1*13 IHS/OIT/FCJ ADDED "U" TYPE RECORD
  1.  .W ?7,ACHSY,".",?10,$$REC^ACHSACO1(ACHSY),?50,$J(ACHSTOTL(ACHSY),6),!
  1.  ;
  1.  W !?20,"TOTAL ALL TYPES",?50,$J(ACHSTOTL,6),!
  1.  S DIC="^ACHSAOLG(",(X,DINUM)=$P(ACHSXD2,U,1)
  1.  S DIC(0)="ZML",DLAYGO=9002077
  1.  D ^DIC
  1.  K DLAYGO
  1.  ;
  1.  I +Y<0 D  Q
  1.  . U IO(0)
  1.  . W *7,"Unable to log Facility name in '",$P($G(^ACHSAOLG(0)),U),"' file",!
  1.  . S ACHSOK=0
  1.  ;
  1.  ;
  1.  I +Y'=ACHSFCPT D  Q
  1.  . U IO(0)
  1.  . W *7,"Facility Lookup error in '",$P($G(^ACHSAOLG(0)),U),"' file",!
  1.  . S ACHSOK=0
  1.  ;
  1.  ;
  1.  S DA(1)=+Y
  1.  I '$D(^ACHSAOLG(ACHSFCPT,1,ACHSDRUN)) S ^ACHSAOLG(ACHSFCPT,1,0)=$$ZEROTH^ACHS(9002077,1)
  1.  S DIC="^ACHSAOLG("_DA(1)_",1,"
  1.  S (DA,X,DINUM)=ACHSDRUN
  1.  D ^DIC
  1.  ;
  1.  I +Y<1 D  Q
  1.  . U IO(0)
  1.  . W *7,"Unable to log Facility Export date in '",$P($G(^ACHSAOLG(0)),U),"' file",!
  1.  . S ACHSOK=0
  1.  ;
  1.  ;
  1.  S Z=+$P(Y,U,2)                              ;CHS AO PROCESSING LOG FILE
  1.  S $P(^ACHSAOLG(ACHSFCPT,1,Z,0),U,2)=ACHSFREC   ;'BEGINNING DATE'
  1.  S $P(^ACHSAOLG(ACHSFCPT,1,Z,0),U,3)=ACHSLREC   ;'ENDING DATE'
  1.  S $P(^ACHSAOLG(ACHSFCPT,1,Z,0),U,4)=ACHSNRCD   ;'DHR RECORD COUNT'
  1.  S $P(^ACHSAOLG(ACHSFCPT,1,Z,0),U,5)=DT         ;AP PROCESSING DATE'
  1.  S $P(^ACHSAOLG(ACHSFCPT,1,Z,0),U,6)=ACHSFN     ;FILE NAME  ;ACHS*3.1*19
  1.  ;
  1.  ;ACHS*3.1*14 9.12.2007 IHS/OIT/FCJ SHOULD CHECK TYPE 5 FI REC NOT DHR, CHG 2 TO 5 IN NXT 2 LINES
  1.  I '$D(ACHSTOTL(5)) G S16
  1.  I ACHSTOTL(5)<1 G S16
  1.  ;
  1.  S:'$D(ACHSCTFI) ACHSCTFI=0
  1.  S ACHSCTFI=ACHSCTFI+1
  1.  S ^ACHSBCBS(ACHSCTFI)="AA"_$P(ACHSXD2,U)_" "_$E(ACHSFREC,4,7)_$E(ACHSFREC,2,3)_" "_$E(ACHSLREC,4,7)_$E(ACHSLREC,2,3)_" "_$E(ACHSDRUN,4,7)_$E(ACHSDRUN,2,3)_$J("",51)
  1. S16 ;
  1.  S ^ACHSZOCT("BCBS")=ACHSCTFI
  1.  S ^ACHSZOCT("AOPD")=ACHSCTPD
  1.  S $P(^ACHSAOVU(0),U)=ACHSCTV
  1.  S $P(^ACHSAOVU(0),U,2)=ACHSCTVS
  1.  S ^ACHSZOCT("PIG")=ACHSCTPG
  1.  S ^ACHSPIG(0,0)=ACHSCTPG
  1.  S ^ACHSPG2(0,0)=ACHSCTP2   ;ACHS*3.1*23  ICD-10 FORMAT
  1.  S ^ACHSUFMS(0)=ACHSCTUA
  1.  S ^ACHSUFMS("COUNT")=ACHSCTUF  ;ACHS*3.1*13 IHS/OIT/FCJ ADDED TOTAL REC COUNT FOR UFMS RECORDS
  1. K ; Close device, kill vars, quit. 
  1.  D ^%ZISC ; ,EN^XBVK("ACHS"),^ACHSVAR
  1.  Q
  1.  ;
  1. TERR ;EP.
  1.  U IO(0)
  1.  W *7,!!,"An Error has been detected while transferring CHS data.",!!,"Please notify your supervisor.",!
  1.  D RTRN^ACHS
  1.  D K
  1.  Q
  1.  ;
  1. END1 ;EP.
  1.  S ACHSOK=1
  1.  U IO(0)
  1.  W !!,"No CHS Data Transferred"
  1.  D RTRN^ACHS
  1.  D K
  1.  Q
  1.  ;
  1. REPORT ;EP
  1.  U ACHSIO
  1.  X:$D(ACHSPPO) ACHSPPO  ;IF SLAVE PRINTER SETTINGS EXECUTE THEM
  1.  K ACHSZFAC("TOTAL")
  1.  S ACHSZFAC("TOTAL")=0
  1.  W @IOF,!?22,"AREA OFFICE CHS CONSOLIDATION REPORT",!,$$C^XBFUNC("FOR "_$$LOC^ACHS,80),!,$$C^XBFUNC($$FMTE^XLFDT(DT),80),!,$$REPEAT^XLFSTR("-",79)
  1. REPORTA ;ACHS*3.1*13 IHS/OIT/FCJ MODIFIED REPORT PAGE
  1.  W !,"FACILITY FAC-CD  |------R E C O R D   T Y P E S------|",?53,"TOTAL",?63,"EXP-DATE",!,$$REPEAT^XLFSTR("-",79),!?15
  1.  F %=2:1:7,"U" W $J(%,5)  ;ACHS*3.1*13 IHS/OIT/FCJ ADDED "U"
  1.  W !,$$REPEAT^XLFSTR("-",79),!
  1.  S ACHSI="",ACHSII=""
  1. REPORT1 ;
  1.  S ACHSI=$O(ACHSZFAC(ACHSI))
  1.  G REPORTND:+ACHSI=0
  1.  S ACHSII=""
  1.  ;
  1.  ;'INSTITUTION NAME'                    'ASUFAC INDEX'
  1.  W $E($P($G(^DIC(4,ACHSI,0)),U),1,8),?9,$P($G(^AUTTLOC(ACHSI,0)),U,10)
  1. REPORT1A ;
  1.  S ACHSII=$O(ACHSZFAC(ACHSI,ACHSII))
  1.  G REPORT1:ACHSII=""
  1.  W ?15
  1.  D REPORT1B
  1.  S ACHSZTOT=0
  1.  ;ACHS*3.1*13 IHS/OIT/FCJ ADDED "U" TO NXT LINE
  1.  F ACHSJ=2:1:7,"U" S:$D(ACHSZFAC(ACHSI,ACHSII,ACHSJ)) ACHSZTOT=ACHSZTOT+ACHSZFAC(ACHSI,ACHSII,ACHSJ)
  1.  W ?53,$J(ACHSZTOT,4),?63,$$DASHDATE($P(ACHSZFAC(ACHSI,ACHSII,0),U,2))
  1.  W !,"  BEG-REC DATE:",$$DASHDATE($P(ACHSZFAC(ACHSI,ACHSII,0),U,3)),"  END-REC DATE:",$$DASHDATE($P(ACHSZFAC(ACHSI,ACHSII,0),U,4)),!
  1.  S ACHSZFAC("TOTAL")=ACHSZFAC("TOTAL")+ACHSZTOT
  1.  G REPORT1A
  1.  ;
  1. REPORTND ;
  1.  W !?5,"TOTALS",?15
  1.  ;ACHS*3.1*13 IHS/OIT/FCJ ADDED "U" TO NXT LINE
  1.  F ACHSJ=2:1:7,"U" W $S($D(ACHSZFAC("TOTAL",ACHSJ)):$J(ACHSZFAC("TOTAL",ACHSJ),5),1:$J("",5))
  1.  W ?53,$J(ACHSZFAC("TOTAL"),5),!?5
  1. REPORTNX ;
  1.  I $D(ACHSPPC) W @IOF X ACHSPPC     ;CLOSE SLAVE DEVICE
  1.  Q
  1.  ;
  1. FACSUM ;
  1.  S ACHSK="",ACHSKK="",ACHSZFAC("TOTAL")=0
  1. FACSUM1 ;
  1.  S ACHSK=$O(ACHSZFAC(ACHSK))
  1.  I +ACHSK=0 D FACSUMND Q
  1. FACSUM2 ;
  1.  S ACHSKK=$O(ACHSZFAC(ACHSK,ACHSKK))
  1.  G FACSUM1:+ACHSKK=0
  1.  S ACHSZFAC("TOTAL")=ACHSZFAC("TOTAL")+$P(ACHSZFAC(ACHSK,ACHSKK),U,5)
  1.  G FACSUM2
  1.  ;
  1. FACSUMND ;
  1.  Q
  1.  ;
  1. REPORT1B ;
  1.  ;ACHS*3.1*13 IHS/OIT/FCJ ADDED "U" TO NXT LINE
  1.  F ACHSJ=2:1:7,"U" D
  1.  . I '$D(ACHSZFAC(ACHSI,ACHSII,ACHSJ)) W $J("",5) Q
  1.  . W $J($G(ACHSZFAC(ACHSI,ACHSII,ACHSJ)),5)
  1.  . S ACHSZFAC("TOTAL",ACHSJ)=$G(ACHSZFAC("TOTAL",ACHSJ))+ACHSZFAC(ACHSI,ACHSII,ACHSJ)
  1.  ;
  1.  Q
  1.  ;
  1. DASHDATE(X) ; Return FM date in mm-dd-yy format
  1.  Q $E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)
  1.  ;