BQIIPCME ;GDIT/HS/ALA-Get IPC Monthly Data Export by Provider ; 11 Oct 2011 4:10 PM
;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
;
;
RET(DATA,DATE,PLIST) ;EP -- BQI IPC PROV MON EXPORT NDW
NEW UID,II,HDR,C1,C2,C3,C4,NAME,HEAD,HX,PEC,SORT,QFL,PCT,CT,DDATA,CPER,PPER,TIT,BQMON
NEW BN,LIST,FAC,ASUFAC,DBID
;S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S UID=$J
;S DATA=$NA(^TMP("BQIIPCME",UID))
S DATA=$NA(^BQIDATA1(UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIIPCME D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
; If a list of IENs, process them instead of entire panel
I $D(PLIST)>0 D
. I $D(PLIST)>1 D
.. S LIST="",BN=""
.. F S BN=$O(PLIST(BN)) Q:BN="" S LIST=LIST_PLIST(BN)
.. K PLIST S PLIST=LIST
;
; 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 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)
;
K Z
S HDR="T00010ASUFAC^T00050PROVIDER^T00015DB_ID^T00060IPC_MEAS^T00015TDATE^T00030NUMERATOR^T00030DENOMINATOR"
;S @DATA@(II)=HDR
;S @DATA@(II)=HDR_$C(30)
;
S (C1,C2,C3,C4,CT,PCT)=0
I $G(PLIST)="" S PROV="" F S PROV=$O(^BQIPROV("AD",DATE,PROV)) Q:PROV="" D RTE(PROV)
I $G(PLIST)'="" F BQI=1:1 S PROV=$P(PLIST,$C(28),BQI) Q:PROV="" D RTE(PROV)
;
S PRV=""
F S PRV=$O(DDATA(PRV)) Q:PRV="" D
. S ID=""
. F S ID=$O(DDATA(PRV,ID)) Q:ID="" D
.. I '$D(Z(PRV,ID,DATE)) Q
.. S FDATA=ASUFAC_U_DBID_U_DDATA(PRV,ID)_Z(PRV,ID,DATE)_U
.. S FDATA=$$TKO^BQIUL1(FDATA,"^")
.. I $P(FDATA,U,4)=0 S $P(FDATA,U,4)=""
.. I $P(FDATA,U,5)=0 S $P(FDATA,U,5)=""
.. ;S II=II+1,@DATA@(II)=FDATA_$C(30)
.. S II=II+1,@DATA@(II)=FDATA
;
DONE ;
K Z,IPRD,IPRN,MEAS,MSDN,MSNN,NA,NDA,NO,NUM1,NUM2,PIEN,PROV,PRVR,PTMN,T,TAG,TEAM,TMM,TMN,TOTP,TPRD,TPRN
K FDATA,FLNM,FTOTF,FTOTP,GP,GPRD,GPRN,I,ID,IDD,IDN,IID,DLAYGO,DOD,DPCP,BQITOTP
WRITE ;
S FLNM=$S('$$PROD^XUPROD():"IPCZ",1:"IPC")
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
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
;
RTE(PRV) ;EP
;S DDATA=""
S PRVR=$P($G(^VA(200,PRV,"NPI")),U,1)
; If provider does not have a National Provider ID
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 DDATA=PRVR_U
S CYR=$E(DT,1,3)
S FAC=$$HME^BQIGPUTL()
NEW %,%H,BGPHOME,BQIH,BQIINDF,BQIINDG,BQIMEASF,BQIMEASG,BQIROU,BQIY,BQIYR
D INP^BQINIGHT
;
S IDD=0
F S IDD=$O(^BQI(90508,1,22,CRN,1,IDD)) Q:'IDD D
. S ID=$P(^BQI(90508,1,22,CRN,1,IDD,0),U,1),MEAS=$P(^(0),U,4),IID=$P(^(0),U,1)
. I ID="" Q
. I $P(^BQI(90508,1,22,CRN,1,IDD,0),U,7)=1 Q
. ;S NID=$$NID(ID) I NID="" S NID=ID
. NEW DA,IENS
. S DA(2)=1,DA(1)=CRN,DA=IDD,IENS=$$IENS^DILF(.DA)
. S CAT=$$GET1^DIQ(90508.221,IENS,.03,"E")
. I CAT="" D
.. S CODE=ID
.. S RIEN=$O(^BQI(90506.1,"B",CODE,"")) I RIEN="" Q
.. S CAT=$$GET1^DIQ(90506.1,RIEN_",",3.02,"E")
. ;
. S DDATA(PRV,ID)=PRVR_U_IID_U_MEAS_U_$$DATE(DATE)_U
. I IID="IPC_PEMP" D Q
.. S IDN=$O(^BQIFAC(FAC,30,"B",IID,"")) I IDN="" D Q
... S $P(Z(PRV,ID,DATE),U,1)=""
... S $P(Z(PRV,ID,DATE),U,2)=""
.. S MSDN=$O(^BQIFAC(FAC,30,IDN,1,"B",DATE,""))
.. I MSDN="" Q
.. S DEN=+$P(^BQIFAC(FAC,30,IDN,1,MSDN,0),U,2),NUM=+$P(^BQIFAC(FAC,30,IDN,1,MSDN,0),U,3)
.. S $P(Z(PRV,ID,DATE),U,1)=NUM,$P(Z(PRV,ID,DATE),U,2)=DEN
. ;
. I IID="IPC_CCTM" D Q
.. S TMN=$O(^BSDPCT("AB",PRV,"")) I TMN="" Q
.. S $P(Z(PRV,ID,DATE),U,1)=""
.. S $P(Z(PRV,ID,DATE),U,2)=""
.. S TMN="" F S TMN=$O(^BSDPCT("AB",PRV,TMN)) Q:TMN="" D
... S TMC=$O(^BQITEAM(TMN,10,"B",IID,"")) I TMC="" Q
... S TMV=$O(^BQITEAM(TMN,10,TMC,10,"B",DATE,"")) I TMV="" Q
... S DEN=+$P(^BQITEAM(TMN,10,TMC,10,TMV,0),U,2),NUM=+$P(^BQITEAM(TMN,10,TMC,10,TMV,0),U,3)
... S $P(Z(PRV,ID,DATE),U,1)=NUM,$P(Z(PRV,ID,DATE),U,2)=DEN
. ;
. S IDN=$O(^BQIPROV(PRV,30,"B",IID,"")) I IDN="" D Q
.. S $P(Z(PRV,ID,DATE),U,1)=""
.. S $P(Z(PRV,ID,DATE),U,2)=""
. D
.. S MSDN=$O(^BQIPROV(PRV,30,IDN,1,"B",DATE,""))
.. I MSDN="" Q
.. S DEN=+$P(^BQIPROV(PRV,30,IDN,1,MSDN,0),U,2),NUM=+$P(^BQIPROV(PRV,30,IDN,1,MSDN,0),U,3)
.. I IID="IPC_TOTP" D Q
... S $P(Z(PRV,ID,DATE),U,2)=$P($G(Z(PRV,ID,DATE)),U,2)+DEN
.. I IID="IPC_REVG" D Q
... I DEN=0 S $P(Z(PRV,ID,DATE),U,1)="",$P(Z(PRV,ID,DATE),U,2)="" Q
... I DEN'=0,NUM=0 S $P(Z(PRV,ID,DATE),U,1)=$P($G(Z(PRV,ID,DATE)),U,1)+0,$P(Z(PRV,ID,DATE),U,2)=$P($G(Z(PRV,ID,DATE)),U,2)+DEN Q
... I DEN'=0,NUM'=0 S $P(Z(PRV,ID,DATE),U,1)=$P($G(Z(PRV,ID,DATE)),U,1)+NUM,$P(Z(PRV,ID,DATE),U,2)=$P($G(Z(PRV,ID,DATE)),U,2)+DEN Q
.. I DEN=0 S $P(Z(PRV,ID,DATE),U,1)=$P($G(Z(PRV,ID,DATE)),U,1)+0,$P(Z(PRV,ID,DATE),U,2)=$P($G(Z(PRV,ID,DATE)),U,2)+0 Q
.. I DEN'=0,NUM=0 S $P(Z(PRV,ID,DATE),U,1)=$P($G(Z(PRV,ID,DATE)),U,1)+0,$P(Z(PRV,ID,DATE),U,2)=$P($G(Z(PRV,ID,DATE)),U,2)+DEN Q
.. I NUM'=0 S $P(Z(PRV,ID,DATE),U,1)=$P($G(Z(PRV,ID,DATE)),U,1)+NUM,$P(Z(PRV,ID,DATE),U,2)=$P($G(Z(PRV,ID,DATE)),U,2)+DEN
Q
;
NID(ID) ;EP
NEW MDATA,IDIN
I $P(ID,"_",1)'=BQIYR Q ID
S IDIN=$P(ID,"_",2)
S MDATA=$G(@BQIMEASG@(IDIN,17))
Q $P(MDATA,U,8)
;
FDATE(D) ;
Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)
;
DATE(DATE) ;EP
NEW BQMON,BEGDT,CYR,BQDTE,EDAY,EDATE
S BQMON=+$E(DATE,4,5)
S BEGDT=$E(DATE,1,5)_"01"
S CYR=$E(DT,1,3)
S BQDTE=$P($T(BQM+BQMON),";;",2)
S EDAY="31^"_($$LEAP^XLFDT2($P(BQDTE,U,2))+28)_"^31^30^31^30^31^31^30^31^30^31"
S EDATE=$E(DATE,1,5)_$P(EDAY,U,BQMON)
Q $$FMTMDY^BQIUL1(EDATE)
;
BQM ;
;;01^CYR
;;02^CYR
;;03^CYR
;;04^CYR
;;05^CYR
;;06^CYR
;;07^CYR
;;08^CYR
;;09^CYR
;;10^CYR
;;11^CYR
;;12^CYR
BQIIPCME ;GDIT/HS/ALA-Get IPC Monthly Data Export by Provider ; 11 Oct 2011 4:10 PM
+1 ;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
+2 ;
+3 ;
RET(DATA,DATE,PLIST) ;EP -- BQI IPC PROV MON EXPORT NDW
+1 NEW UID,II,HDR,C1,C2,C3,C4,NAME,HEAD,HX,PEC,SORT,QFL,PCT,CT,DDATA,CPER,PPER,TIT,BQMON
+2 NEW BN,LIST,FAC,ASUFAC,DBID
+3 ;S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
+4 SET UID=$JOB
+5 ;S DATA=$NA(^TMP("BQIIPCME",UID))
+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^BQIIPCME D UNWIND^%ZTER"
+10 ; If a list of IENs, process them instead of entire panel
+11 IF $DATA(PLIST)>0
Begin DoDot:1
+12 IF $DATA(PLIST)>1
Begin DoDot:2
+13 SET LIST=""
SET BN=""
+14 FOR
SET BN=$ORDER(PLIST(BN))
IF BN=""
QUIT
SET LIST=LIST_PLIST(BN)
+15 KILL PLIST
SET PLIST=LIST
End DoDot:2
End DoDot:1
+16 ;
+17 ; Get current IPC
+18 SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+19 IF CRIPC'="IPCMH"
SET CRIPC="IPCMH"
+20 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+21 SET ASUFAC=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)
+22 SET DBID=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),1)),U,3)
+23 ;
+24 KILL Z
+25 SET HDR="T00010ASUFAC^T00050PROVIDER^T00015DB_ID^T00060IPC_MEAS^T00015TDATE^T00030NUMERATOR^T00030DENOMINATOR"
+26 ;S @DATA@(II)=HDR
+27 ;S @DATA@(II)=HDR_$C(30)
+28 ;
+29 SET (C1,C2,C3,C4,CT,PCT)=0
+30 IF $GET(PLIST)=""
SET PROV=""
FOR
SET PROV=$ORDER(^BQIPROV("AD",DATE,PROV))
IF PROV=""
QUIT
DO RTE(PROV)
+31 IF $GET(PLIST)'=""
FOR BQI=1:1
SET PROV=$PIECE(PLIST,$CHAR(28),BQI)
IF PROV=""
QUIT
DO RTE(PROV)
+32 ;
+33 SET PRV=""
+34 FOR
SET PRV=$ORDER(DDATA(PRV))
IF PRV=""
QUIT
Begin DoDot:1
+35 SET ID=""
+36 FOR
SET ID=$ORDER(DDATA(PRV,ID))
IF ID=""
QUIT
Begin DoDot:2
+37 IF '$DATA(Z(PRV,ID,DATE))
QUIT
+38 SET FDATA=ASUFAC_U_DBID_U_DDATA(PRV,ID)_Z(PRV,ID,DATE)_U
+39 SET FDATA=$$TKO^BQIUL1(FDATA,"^")
+40 IF $PIECE(FDATA,U,4)=0
SET $PIECE(FDATA,U,4)=""
+41 IF $PIECE(FDATA,U,5)=0
SET $PIECE(FDATA,U,5)=""
+42 ;S II=II+1,@DATA@(II)=FDATA_$C(30)
+43 SET II=II+1
SET @DATA@(II)=FDATA
End DoDot:2
End DoDot:1
+44 ;
DONE ;
+1 KILL Z,IPRD,IPRN,MEAS,MSDN,MSNN,NA,NDA,NO,NUM1,NUM2,PIEN,PROV,PRVR,PTMN,T,TAG,TEAM,TMM,TMN,TOTP,TPRD,TPRN
+2 KILL FDATA,FLNM,FTOTF,FTOTP,GP,GPRD,GPRN,I,ID,IDD,IDN,IID,DLAYGO,DOD,DPCP,BQITOTP
WRITE ;
+1 SET FLNM=$SELECT('$$PROD^XUPROD():"IPCZ",1:"IPC")
+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
+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 ;
RTE(PRV) ;EP
+1 ;S DDATA=""
+2 SET PRVR=$PIECE($GET(^VA(200,PRV,"NPI")),U,1)
+3 ; If provider does not have a National Provider ID
+4 IF PRVR=""
Begin DoDot:1
+5 SET ASUFAC=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)
+6 SET DBID=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),1)),U,3)
+7 SET PRVR=DBID_"_"_PRV
End DoDot:1
+8 ;S DDATA=PRVR_U
+9 SET CYR=$EXTRACT(DT,1,3)
+10 SET FAC=$$HME^BQIGPUTL()
+11 NEW %,%H,BGPHOME,BQIH,BQIINDF,BQIINDG,BQIMEASF,BQIMEASG,BQIROU,BQIY,BQIYR
+12 DO INP^BQINIGHT
+13 ;
+14 SET IDD=0
+15 FOR
SET IDD=$ORDER(^BQI(90508,1,22,CRN,1,IDD))
IF 'IDD
QUIT
Begin DoDot:1
+16 SET ID=$PIECE(^BQI(90508,1,22,CRN,1,IDD,0),U,1)
SET MEAS=$PIECE(^(0),U,4)
SET IID=$PIECE(^(0),U,1)
+17 IF ID=""
QUIT
+18 IF $PIECE(^BQI(90508,1,22,CRN,1,IDD,0),U,7)=1
QUIT
+19 ;S NID=$$NID(ID) I NID="" S NID=ID
+20 NEW DA,IENS
+21 SET DA(2)=1
SET DA(1)=CRN
SET DA=IDD
SET IENS=$$IENS^DILF(.DA)
+22 SET CAT=$$GET1^DIQ(90508.221,IENS,.03,"E")
+23 IF CAT=""
Begin DoDot:2
+24 SET CODE=ID
+25 SET RIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
IF RIEN=""
QUIT
+26 SET CAT=$$GET1^DIQ(90506.1,RIEN_",",3.02,"E")
End DoDot:2
+27 ;
+28 SET DDATA(PRV,ID)=PRVR_U_IID_U_MEAS_U_$$DATE(DATE)_U
+29 IF IID="IPC_PEMP"
Begin DoDot:2
+30 SET IDN=$ORDER(^BQIFAC(FAC,30,"B",IID,""))
IF IDN=""
Begin DoDot:3
+31 SET $PIECE(Z(PRV,ID,DATE),U,1)=""
+32 SET $PIECE(Z(PRV,ID,DATE),U,2)=""
End DoDot:3
QUIT
+33 SET MSDN=$ORDER(^BQIFAC(FAC,30,IDN,1,"B",DATE,""))
+34 IF MSDN=""
QUIT
+35 SET DEN=+$PIECE(^BQIFAC(FAC,30,IDN,1,MSDN,0),U,2)
SET NUM=+$PIECE(^BQIFAC(FAC,30,IDN,1,MSDN,0),U,3)
+36 SET $PIECE(Z(PRV,ID,DATE),U,1)=NUM
SET $PIECE(Z(PRV,ID,DATE),U,2)=DEN
End DoDot:2
QUIT
+37 ;
+38 IF IID="IPC_CCTM"
Begin DoDot:2
+39 SET TMN=$ORDER(^BSDPCT("AB",PRV,""))
IF TMN=""
QUIT
+40 SET $PIECE(Z(PRV,ID,DATE),U,1)=""
+41 SET $PIECE(Z(PRV,ID,DATE),U,2)=""
+42 SET TMN=""
FOR
SET TMN=$ORDER(^BSDPCT("AB",PRV,TMN))
IF TMN=""
QUIT
Begin DoDot:3
+43 SET TMC=$ORDER(^BQITEAM(TMN,10,"B",IID,""))
IF TMC=""
QUIT
+44 SET TMV=$ORDER(^BQITEAM(TMN,10,TMC,10,"B",DATE,""))
IF TMV=""
QUIT
+45 SET DEN=+$PIECE(^BQITEAM(TMN,10,TMC,10,TMV,0),U,2)
SET NUM=+$PIECE(^BQITEAM(TMN,10,TMC,10,TMV,0),U,3)
+46 SET $PIECE(Z(PRV,ID,DATE),U,1)=NUM
SET $PIECE(Z(PRV,ID,DATE),U,2)=DEN
End DoDot:3
End DoDot:2
QUIT
+47 ;
+48 SET IDN=$ORDER(^BQIPROV(PRV,30,"B",IID,""))
IF IDN=""
Begin DoDot:2
+49 SET $PIECE(Z(PRV,ID,DATE),U,1)=""
+50 SET $PIECE(Z(PRV,ID,DATE),U,2)=""
End DoDot:2
QUIT
+51 Begin DoDot:2
+52 SET MSDN=$ORDER(^BQIPROV(PRV,30,IDN,1,"B",DATE,""))
+53 IF MSDN=""
QUIT
+54 SET DEN=+$PIECE(^BQIPROV(PRV,30,IDN,1,MSDN,0),U,2)
SET NUM=+$PIECE(^BQIPROV(PRV,30,IDN,1,MSDN,0),U,3)
+55 IF IID="IPC_TOTP"
Begin DoDot:3
+56 SET $PIECE(Z(PRV,ID,DATE),U,2)=$PIECE($GET(Z(PRV,ID,DATE)),U,2)+DEN
End DoDot:3
QUIT
+57 IF IID="IPC_REVG"
Begin DoDot:3
+58 IF DEN=0
SET $PIECE(Z(PRV,ID,DATE),U,1)=""
SET $PIECE(Z(PRV,ID,DATE),U,2)=""
QUIT
+59 IF DEN'=0
IF NUM=0
SET $PIECE(Z(PRV,ID,DATE),U,1)=$PIECE($GET(Z(PRV,ID,DATE)),U,1)+0
SET $PIECE(Z(PRV,ID,DATE),U,2)=$PIECE($GET(Z(PRV,ID,DATE)),U,2)+DEN
QUIT
+60 IF DEN'=0
IF NUM'=0
SET $PIECE(Z(PRV,ID,DATE),U,1)=$PIECE($GET(Z(PRV,ID,DATE)),U,1)+NUM
SET $PIECE(Z(PRV,ID,DATE),U,2)=$PIECE($GET(Z(PRV,ID,DATE)),U,2)+DEN
QUIT
End DoDot:3
QUIT
+61 IF DEN=0
SET $PIECE(Z(PRV,ID,DATE),U,1)=$PIECE($GET(Z(PRV,ID,DATE)),U,1)+0
SET $PIECE(Z(PRV,ID,DATE),U,2)=$PIECE($GET(Z(PRV,ID,DATE)),U,2)+0
QUIT
+62 IF DEN'=0
IF NUM=0
SET $PIECE(Z(PRV,ID,DATE),U,1)=$PIECE($GET(Z(PRV,ID,DATE)),U,1)+0
SET $PIECE(Z(PRV,ID,DATE),U,2)=$PIECE($GET(Z(PRV,ID,DATE)),U,2)+DEN
QUIT
+63 IF NUM'=0
SET $PIECE(Z(PRV,ID,DATE),U,1)=$PIECE($GET(Z(PRV,ID,DATE)),U,1)+NUM
SET $PIECE(Z(PRV,ID,DATE),U,2)=$PIECE($GET(Z(PRV,ID,DATE)),U,2)+DEN
End DoDot:2
End DoDot:1
+64 QUIT
+65 ;
NID(ID) ;EP
+1 NEW MDATA,IDIN
+2 IF $PIECE(ID,"_",1)'=BQIYR
QUIT ID
+3 SET IDIN=$PIECE(ID,"_",2)
+4 SET MDATA=$GET(@BQIMEASG@(IDIN,17))
+5 QUIT $PIECE(MDATA,U,8)
+6 ;
FDATE(D) ;
+1 QUIT (1700+$EXTRACT(D,1,3))_$EXTRACT(D,4,5)_$EXTRACT(D,6,7)
+2 ;
DATE(DATE) ;EP
+1 NEW BQMON,BEGDT,CYR,BQDTE,EDAY,EDATE
+2 SET BQMON=+$EXTRACT(DATE,4,5)
+3 SET BEGDT=$EXTRACT(DATE,1,5)_"01"
+4 SET CYR=$EXTRACT(DT,1,3)
+5 SET BQDTE=$PIECE($TEXT(BQM+BQMON),";;",2)
+6 SET EDAY="31^"_($$LEAP^XLFDT2($PIECE(BQDTE,U,2))+28)_"^31^30^31^30^31^31^30^31^30^31"
+7 SET EDATE=$EXTRACT(DATE,1,5)_$PIECE(EDAY,U,BQMON)
+8 QUIT $$FMTMDY^BQIUL1(EDATE)
+9 ;
BQM ;
+1 ;;01^CYR
+2 ;;02^CYR
+3 ;;03^CYR
+4 ;;04^CYR
+5 ;;05^CYR
+6 ;;06^CYR
+7 ;;07^CYR
+8 ;;08^CYR
+9 ;;09^CYR
+10 ;;10^CYR
+11 ;;11^CYR
+12 ;;12^CYR
