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

ACHSPCC7.m

Go to the documentation of this file. 
  1. ACHSPCC7 ; IHS/ITSC/PMF - CHS AREA SPLITOUT (2/5)(DHR FOR CORE) ; [ 12/06/2002  10:36 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
  1.  ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Remove direct ref to non-package global.
  1.  S (ACHSFAC,ACHSRR,ACHSHASH,ACHSCT2)=0
  1.  K ACHSFTOT,ACHSFCT,AFSJFLG
  1.  U IO(0)
  1.  W !?10,"GENERATING DHR RECORDS FOR CORE",!!
  1.  D WAIT^DICD
  1.  W:$E(IOST)="P" !
  1.  S (ACHSCT1,X)=$S($D(^ACHSCORE("COUNT")):^("COUNT"),1:100)
  1.  I X'=100 S ACHSCT1=$S(X>9999:100,X>8888:90,X>6666:80,X>4444:70,X>2222:50,X>500:30,1:5)
  1. L1 ; Process a Facility.
  1.  S ACHSFAC=$O(^ACHSCORE(ACHSFAC))
  1.  G LEND:+ACHSFAC=0!(ACHSFAC>999999)
  1.  S (ACHSFTOT(ACHSFAC),ACHSFCT(ACHSFAC))=0
  1. L2 ; Process DHRs from a Facility.
  1.  S ACHSRR=$O(^ACHSCORE(ACHSFAC,ACHSRR))
  1.  G L1:ACHSRR=""
  1.  S ACHS2=$G(^ACHSCORE(ACHSFAC,ACHSRR))
  1.  S ACHS2B=$G(^ACHSCORE(ACHSFAC,ACHSRR+1))
  1.  S ACHS2C=$G(^ACHSCORE(ACHSFAC,ACHSRR+1))
  1.  ;
  1.  I $E(ACHS2)'=2 G L2
  1.  I "BC"[$E(ACHS2,2) G L2
  1.  I $E(ACHS2B,1,2)'="2B" D  I 1
  1.  . ; PROGRAMMER NOTE:  This subroutine only gets called if record 2B
  1.  . ;                   doesn't exist.  This subroutine should be
  1.  . ;                   removed before 2000, because of the limits on
  1.  . ;                   calculating FY, using 90 as a base.    
  1.  . S ACHS2B=$J("",80)
  1.  . S $E(ACHS2B,1,2)="2B"
  1.  . S $E(ACHS2B,3,6)=($$VAL^XBDIQ1("^AUTTLOC(",DUZ(2),.31)_".")
  1.  . ;begin Y2K block
  1.  . ;S $E(ACHS2B,59,60)=($E(ACHS2,40)+90) ; Guesstimate the FY.
  1.  . N X,X2 ;JUST IN CASE IT IS NEEDED FROM ELSEWHERE
  1.  . S X=$E(ACHSCFY,1,3)_$E(ACHS2,40) ;ASSUME CURRENT FISCAL YEAR
  1.  . S X2=ACHSFY-X,X=X+$S(X2>8:10,X2<-1:-10,1:0) ;ADJUST WINDOW
  1.  . S $E(ACHS2B,57,60)=X
  1.  . ;end Y2K block
  1.  . I $L(ACHS2B)'=80 S ACHS2B=$J("",80)
  1.  .Q
  1.  E  K ^ACHSCORE(ACHSFAC,ACHSRR+1)
  1.  I $E(ACHS2C,1,2)'="2C" S ACHS2C=$J("",80)
  1.  E  K ^ACHSCORE(ACHSFAC,ACHSRR+2)
  1.  S ACHSCT2=ACHSCT2+1
  1.  I ACHSCT2#ACHSCT1=0 U IO(0) W $J(ACHSCT2,8)
  1.  S ACHSCORE(1)=$E(ACHS2B,3,6)_"    "
  1.  S ACHSCORE(2)=$S($E(ACHS2,11,23)=13:"N",1:"A")
  1.  S ACHSCORE(3)=$E(ACHS2,9,12)
  1.  S ACHSCORE(10)=$E(ACHS2,48,51)
  1.  S ACHSCORE(12)="0000"_$E(ACHS2,52,63)
  1.  I ACHSCORE(3)="5024" S X="19"_$S(ACHSCORE(10)="2185":"2",1:"1")_"14",ACHSCORE(12)=$$REPEAT^XLFSTR("0",16)
  1.  S ACHSCORE(4)=ACHSEFDT
  1.  S ACHSCORE(5)=$E(ACHS2B,59,60)
  1.  S ACHSCORE(6)="       "_$E(ACHS2,13,15)
  1.  S ACHSCORE(7)=$E(ACHS2,16,25)
  1.  S ACHSCORE(8)=" "_$E(ACHS2,41,47)
  1.  S ACHSCORE(9)=$E(ACHS2B,7,36)
  1.  S ACHSCORE(11)=$E(ACHS2B,37,56)
  1.  S ACHSCORE(13)="+" ; When does this need to be "-"?  GTH 05-30-97
  1.  S ACHSCORE(19)=$E(ACHS2C,3,14)
  1.  S ACHSCORE(20)=$E(ACHS2C,15,44)
  1.  S ACHSCORE(21)=$E(ACHS2C,45,74)
  1.  S ACHSCORE(46)="IHS "
  1.  S X=""
  1.  F %=1:1:13 S X=X_ACHSCORE(%)
  1.  S X=X_$J("",314)_ACHSCORE(46)_$J("",142)
  1.  I $L(X)'=580 W *7,!!,"A DHR for CORE was produced that was not 580 characters." D JOBABEND^ACHSPCC4 Q
  1.  S ^ACHSCORE(ACHSFAC,ACHSRR)=$E(X,1,290),^(ACHSRR,1)=$E(X,291,580)
  1.  S ACHSHASH=ACHSHASH+$E(ACHS2,52,63),ACHSFTOT(ACHSFAC)=ACHSFTOT(ACHSFAC)+$E(ACHS2,52,63),ACHSFCT(ACHSFAC)=ACHSFCT(ACHSFAC)+1
  1.  K ACHS2,ACHS2B,ACHS2C,ACHSCORE
  1.  G L2
  1.  ;
  1. LEND ;
  1.  U IO(0)
  1.  W !!,"TOTAL DHR RECORDS GENERATED = ",ACHSCT2,!
  1.  D RTRN^ACHS,HDR1
  1.  S ACHSHASH=$E(ACHSHASH+1000000000000,2,13),ACHSCT2=$E(ACHSCT2+10000,2,5)
  1.  K ACHSDES1,ACHSZDOC
  1.  S ACHSFAC=""
  1.  F  S ACHSFAC=$O(ACHSFTOT(ACHSFAC)) Q:ACHSFAC=""  D
  1.  . S X=ACHSFTOT(ACHSFAC)/100,X2=2,X3=16
  1.  . D COMMA^%DTC
  1.  . W ?10,$E($P(^DIC(4,$O(^AUTTLOC("C",ACHSFAC,0)),0),U),1,30),?46,$J(ACHSFCT(ACHSFAC),5),?55,X,!!
  1.  . I $Y>(IOSL-6) D RTRN^ACHS,HDR1
  1.  .Q
  1.  W ?10,$E(Y,1,60)
  1.  S X=+ACHSHASH/100,X2="2$",X3=16
  1.  D COMMA^%DTC
  1.  W !!?15,"TOTAL CHS TRANSACTIONS",?51-$L($J(ACHSCT2,0,0)),$J(ACHSCT2,0,0),?55,X,!!?10,"NUMBER OF OUTPUT DHR RECORDS = ",?46,$J((ACHSCT2+2)*2,5)
  1.  S ACHSJCLC=8
  1.  W !!?10,"NUMBER OF JCL RECORDS = ",?46,$J(ACHSJCLC,5),!!?10,$E(Y,1,41)
  1.  S ACHSTXCT=((ACHSCT2+2)*2)+ACHSJCLC
  1.  W !?15,"TOTAL RECORDS TO TRANSMIT = ",?46,$J(ACHSTXCT,5),!!
  1.  D RTRN^ACHS
  1.  W @IOF
  1.  ;I $P($G(^AFSHPARM(DUZ(2),0)),U,5)["N" D ^%ZISC I 1 ; Allow posting of DHR Date to 1166;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  I $$GET1^DIQ(9002322.3,DUZ(2),1.03)["N" D ^%ZISC I 1 ; Allow posting of DHR Date to 1166;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  E  S ACHSPTRD=IO ; Allow 1166 posting.
  1.  D HOME^%ZIS
  1.  K ACHSFTOT
  1.  Q
  1.  ;
  1. HDR1 ;
  1.  U IO
  1.  S (X,Y)="",$P(X,"*",71)="",$P(Y,"-",69)=""
  1.  W @IOF,!?5,X,!?5,"*",?10,"C H S  DATA  SPLIT-OUT (EXPORT)  FOR: ",$E($$LOC^ACHS,1,25),?74,"*",!?5,"*",?5,$E(DT,4,5),"-",$E(DT,6,7),"-",$E(DT,2,3),?22,"TRANSACTION  TOTALS  BY  FACILITY",?74,"*",!
  1.  W ?5,"*",Y,"*",!?5,"*"," THE DESTINATION OF THESE DATA RECORDS IS: ",$S('($$AOP^ACHS(2,8)="Y"):"PARKLAWN COMPUTER CENTER",$$AOP^ACHS(2,8)="Y":"BLUE CROSS/SHIELD OF NM",1:" "),?74,"*",!
  1.  W ?5,"*",Y,"*",!?5,"*",?10,"NAME OF FACILITY",?44,"NUMB TRNS",?60,"DOLLAR AMT",?74,"*",!?5,X,!!
  1.  Q
  1.  ;