BQIIPCMF ;GDIT/HCSD/ALA-Monthly File Output ; 16 Mar 2018 7:35 AM
;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
;
PROV ;EP - Provider List
NEW UID,II,HDR,PRV,PRVR,TEAM,ASUFAC,TRMDT,TMN,TMNM,DBID
;S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S UID=$J
S DATA=$NA(^BQIDATA1(UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIIPCMF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S HDR="T00010ASUFAC^T000020PROV_ID^T00050PROVIDER^D00015INACTIVE_DATE^T00050TEAM"
S ASUFAC=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)
S PRV="" F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" D
. S PRVR=$P($G(^VA(200,PRV,"NPI")),U,1)
. I PRVR="" D
.. S ASUFAC=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)
.. S DBID=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),1)),U,3)
.. S PRVR=DBID_"_"_PRV
. S TRMDT=$P($G(^VA(200,PRV,0)),"^",11)
. S TEAM=""
. S TMN="" F S TMN=$O(^BSDPCT("AB",PRV,TMN)) Q:TMN="" D
.. S TMNM=$P(^BSDPCT(TMN,0),U,1),TEAM=TEAM_TMNM_"; "
. S TEAM=$$TKO^BQIUL1(TEAM,"; ")
. S II=II+1,@DATA@(II)=ASUFAC_U_DBID_U_PRVR_U_$P(^VA(200,PRV,0),"^",1)_U_$$DATE^BQIIPCME(TRMDT)_U_TEAM
D WRITE("PROV")
Q
;
MEAS ;EP - Measure List
NEW UID,II,HDR,VER,XVER,CRIPC,CRN
D EN^BQIVER(.XVER,"BGP")
S VER=$P(@XVER@(2),U,2)_$S($P(@XVER@(2),U,4)'="":"p"_$P(@XVER@(2),U,4),1:"")
;S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S UID=$J
S DATA=$NA(^BQIDATA1(UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIIPCMF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S HDR="T00010ASUFAC^T000020MEAS_ID^T00050MEAS_NAME"
S ASUFAC=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)
S DBID=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),1)),U,3)
; Get current IPC
S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
I CRIPC'="IPCMH" S CRIPC="IPCMH"
S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
;
S MN=0 F S MN=$O(^BQI(90508,1,22,CRN,1,MN)) Q:'MN D
. S ID=$P(^BQI(90508,1,22,CRN,1,MN,0),"^",1)
. S II=II+1,@DATA@(II)=ASUFAC_U_DBID_U_VER_U_ID_U_$P(^BQI(90508,1,22,CRN,1,MN,0),"^",4)
D WRITE("MEAS")
Q
;
WRITE(NAME) ;EP - Write out to file
S FLNM=$S('$$PROD^XUPROD():"IPCZ",1:"IPC")_NAME
S ZTQUEUED=1
NEW XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN
S XBMED="F",XBQ="N",XBFLT=1,XBF=UID,XBE=UID
S XBGL="BQIDATA1"
S XBNAR="IPC DATA WAREHOUSE EXPORT"
S ASUFAC=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10) ;asufac for file name
S XBFN=FLNM_"_"_ASUFAC_"_"_$$FDATE(DT)_".txt"
S XBS1="DATA WAREHOUSE SEND"
S XBUF=$P($G(^AUTTSITE(1,1)),"^",2)
I XBUF="" S XBUF=$P($G(^XTV(8989.3,1,"DEV")),"^",1)
;
D ^XBGSAVE
K @DATA,ZTQUEUED,FLN,ASUFAC,XBS1,FLNM
K V,VAL,VISIT,WDA,XBFLG,XBFLG(1),XBPAFN,XBS1,YEAR,YES,ZISHC,ZISHDA1,ZTQUEUED
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
FDATE(D) ;
Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)
BQIIPCMF ;GDIT/HCSD/ALA-Monthly File Output ; 16 Mar 2018 7:35 AM
+1 ;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
+2 ;
PROV ;EP - Provider List
+1 NEW UID,II,HDR,PRV,PRVR,TEAM,ASUFAC,TRMDT,TMN,TMNM,DBID
+2 ;S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
+3 SET UID=$JOB
+4 SET DATA=$NAME(^BQIDATA1(UID))
+5 KILL @DATA
+6 SET II=0
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIIPCMF D UNWIND^%ZTER"
+8 SET HDR="T00010ASUFAC^T000020PROV_ID^T00050PROVIDER^D00015INACTIVE_DATE^T00050TEAM"
+9 SET ASUFAC=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)
+10 SET PRV=""
FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:1
+11 SET PRVR=$PIECE($GET(^VA(200,PRV,"NPI")),U,1)
+12 IF PRVR=""
Begin DoDot:2
+13 SET ASUFAC=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)
+14 SET DBID=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),1)),U,3)
+15 SET PRVR=DBID_"_"_PRV
End DoDot:2
+16 SET TRMDT=$PIECE($GET(^VA(200,PRV,0)),"^",11)
+17 SET TEAM=""
+18 SET TMN=""
FOR
SET TMN=$ORDER(^BSDPCT("AB",PRV,TMN))
IF TMN=""
QUIT
Begin DoDot:2
+19 SET TMNM=$PIECE(^BSDPCT(TMN,0),U,1)
SET TEAM=TEAM_TMNM_"; "
End DoDot:2
+20 SET TEAM=$$TKO^BQIUL1(TEAM,"; ")
+21 SET II=II+1
SET @DATA@(II)=ASUFAC_U_DBID_U_PRVR_U_$PIECE(^VA(200,PRV,0),"^",1)_U_$$DATE^BQIIPCME(TRMDT)_U_TEAM
End DoDot:1
+22 DO WRITE("PROV")
+23 QUIT
+24 ;
MEAS ;EP - Measure List
+1 NEW UID,II,HDR,VER,XVER,CRIPC,CRN
+2 DO EN^BQIVER(.XVER,"BGP")
+3 SET VER=$PIECE(@XVER@(2),U,2)_$SELECT($PIECE(@XVER@(2),U,4)'="":"p"_$PIECE(@XVER@(2),U,4),1:"")
+4 ;S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
+5 SET UID=$JOB
+6 SET DATA=$NAME(^BQIDATA1(UID))
+7 KILL @DATA
+8 SET II=0
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIIPCMF D UNWIND^%ZTER"
+10 SET HDR="T00010ASUFAC^T000020MEAS_ID^T00050MEAS_NAME"
+11 SET ASUFAC=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)
+12 SET DBID=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),1)),U,3)
+13 ; Get current IPC
+14 SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+15 IF CRIPC'="IPCMH"
SET CRIPC="IPCMH"
+16 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+17 ;
+18 SET MN=0
FOR
SET MN=$ORDER(^BQI(90508,1,22,CRN,1,MN))
IF 'MN
QUIT
Begin DoDot:1
+19 SET ID=$PIECE(^BQI(90508,1,22,CRN,1,MN,0),"^",1)
+20 SET II=II+1
SET @DATA@(II)=ASUFAC_U_DBID_U_VER_U_ID_U_$PIECE(^BQI(90508,1,22,CRN,1,MN,0),"^",4)
End DoDot:1
+21 DO WRITE("MEAS")
+22 QUIT
+23 ;
WRITE(NAME) ;EP - Write out to file
+1 SET FLNM=$SELECT('$$PROD^XUPROD():"IPCZ",1:"IPC")_NAME
+2 SET ZTQUEUED=1
+3 NEW XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN
+4 SET XBMED="F"
SET XBQ="N"
SET XBFLT=1
SET XBF=UID
SET XBE=UID
+5 SET XBGL="BQIDATA1"
+6 SET XBNAR="IPC DATA WAREHOUSE EXPORT"
+7 ;asufac for file name
SET ASUFAC=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)
+8 SET XBFN=FLNM_"_"_ASUFAC_"_"_$$FDATE(DT)_".txt"
+9 SET XBS1="DATA WAREHOUSE SEND"
+10 SET XBUF=$PIECE($GET(^AUTTSITE(1,1)),"^",2)
+11 IF XBUF=""
SET XBUF=$PIECE($GET(^XTV(8989.3,1,"DEV")),"^",1)
+12 ;
+13 DO ^XBGSAVE
+14 KILL @DATA,ZTQUEUED,FLN,ASUFAC,XBS1,FLNM
+15 KILL V,VAL,VISIT,WDA,XBFLG,XBFLG(1),XBPAFN,XBS1,YEAR,YES,ZISHC,ZISHDA1,ZTQUEUED
+16 QUIT
+17 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
FDATE(D) ;
+1 QUIT (1700+$EXTRACT(D,1,3))_$EXTRACT(D,4,5)_$EXTRACT(D,6,7)
