- 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)
