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