- 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
