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