BQIIPCFX ;GDIT/HS/ALA-Fix IPC ; 02 Jan 2014 12:36 PM
;;2.3;ICARE MANAGEMENT SYSTEM;**5**;Apr 18, 2012;Build 17
;
NEW BI,FROW,BQDATE,PRN,PROW
F BI=1:1:16 S FROW=$P($T(ROW+BI),";;",2) D
. S BQDATE=$P(FROW,U,1),ROW=$P(FROW,U,2)
. S PRN=$O(^BQI(90508,1,22,2,3,"B",BQDATE,"")) I PRN="" Q
. S PROW=$P(^BQI(90508,1,22,2,3,PRN,0),U,2)
. I PROW'=ROW S $P(^BQI(90508,1,22,2,3,PRN,0),U,2)=ROW
;
NEW ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSAVE,BQIUPD
S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),,,3)
S ZTDESC="IPC Update Compile",ZTRTN="JOB^BQIIPCFX",ZTIO=""
D ^%ZTLOAD
S BQIUPD(90508,"1,",11.04)=ZTSK
D FILE^DIE("","BQIUPD","ERROR")
Q
;
JOB ;EP
I '$D(^BQI(90508,1,22,2,3,"B",3141100)) D
. S BQDATE=3141100 D EN^BQIIPMNU
I '$D(^BQI(90508,1,22,2,3,"B",3141200)) D
. S BQDATE=3141200 D EN^BQIIPMNU
I '$D(^BQI(90508,1,22,2,3,"B",3150100)) D IJB^BQINIGH3(3150100)
;
MU ;EP Fix MU
NEW BQIPROV
S BQIPROV=0
F S BQIPROV=$O(^BQIPROV(BQIPROV)) Q:'BQIPROV D
. F CODE="MU_5","MU_6","MU_7","MU_8" D
.. S MPDN=$O(^BQIPROV(BQIPROV,30,"B",CODE,"")) Q:MPDN=""
.. S MPDT=3121200
.. F S MPDT=$O(^BQIPROV(BQIPROV,30,MPDN,1,"B",MPDT)) Q:MPDT="" D
... S BEGDT=$E(MPDT,1,5)_"01",CYR=$E(MPDT,1,3),BQMON=$E(MPDT,4,5)
... I $L(BQMON)=1 S BQMON="0"_BQMON
... S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
... S ENDT=$E(MPDT,1,5)_$P(EDAY,U,+BQMON)
... S BQDATE=MPDT
... D MU^BQIIPSNG
. I MPDN="" Q
. S BQDATE=3121200
. F S BQDATE=$O(^BQIPROV(BQIPROV,30,MPDN,1,"B",BQDATE)) Q:BQDATE="" D
.. ; Update the MU bundles
.. NEW MPRN,IPRN,IPRD,DEN,NUM,MCOD,MPRD,MBUN
.. S MPRN=$O(^BQIPROV(BQIPROV,30,"B","IPC_WGT",""))
.. I MPRN'="" S MPRD=$O(^BQIPROV(BQIPROV,30,MPRN,1,"B",BQDATE,""))
.. K MBUN
.. F MCOD="MU_8","MU_6","MU_7" D
... S IPRN=$O(^BQIPROV(BQIPROV,30,"B",MCOD,"")) I IPRN="" Q
... S IPRD=$O(^BQIPROV(BQIPROV,30,IPRN,1,"B",BQDATE,"")) I IPRD="" Q
... S DEN=$P(^BQIPROV(BQIPROV,30,IPRN,1,IPRD,0),U,2),NUM=$P(^(0),U,3)
... S MBUN(+DEN)=+NUM
.. S DEN=$O(MBUN(""))
.. S:DEN="" NUM="" S:DEN'="" NUM=MBUN(DEN)
.. I MPRN'="",MPRD'="" D
... S $P(^BQIPROV(BQIPROV,30,MPRN,1,MPRD,0),U,2)=DEN,$P(^BQIPROV(BQIPROV,30,MPRN,1,MPRD,0),U,3)=NUM
;
F CODE="MU_5","MU_6","MU_7","MU_8","IPC_WGT" D
. S BPRV=0 K TDEN,TNUM
. F S BPRV=$O(^BQIPROV(BPRV)) Q:'BPRV D
.. S MPDN=$O(^BQIPROV(BPRV,30,"B",CODE,"")) I MPDN="" Q
.. S BDT=3131200
.. F S BDT=$O(^BQIPROV(BPRV,30,MPDN,1,"B",BDT)) Q:BDT="" D
... S MIEN=$O(^BQIPROV(BPRV,30,MPDN,1,"B",BDT,"")) I MIEN="" Q
... S DEN=$P(^BQIPROV(BPRV,30,MPDN,1,MIEN,0),U,2),NUM=$P(^(0),U,3)
... S TDEN(BDT)=$G(TDEN(BDT))+DEN,TNUM(BDT)=$G(TNUM(BDT))+NUM
. S BDT=""
. F S BDT=$O(TDEN(BDT)) Q:BDT="" D
.. S FAC=$$HME^BQIGPUTL()
.. D STORF^BQIIPUTL(FAC,CODE,BDT,TDEN(BDT),TNUM(BDT))
. K TDEN,TNUM
;
NEW BQD,BQX,BQDATE,CODE,PRV,TDEN,TNUM,IPRN,IPRD,DEN,NUM,FAC,Y
S BQD=3140800
F S BQD=$O(^BQI(90508,1,22,2,3,"B",BQD)) Q:BQD="" S BQX(BQD)=""
S BQDATE=""
F S BQDATE=$O(BQX(BQDATE)) Q:BQDATE="" D
. S MSN=0,CRN=2
. F S MSN=$O(^BQI(90508,1,22,CRN,1,MSN)) Q:'MSN D
.. S IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
.. S CODE=$P(IDATA,U,1),TYP=$P(IDATA,U,2)
.. ; If inactive, quit
.. I $P(IDATA,U,7)=1 Q
.. ; If type is CRS, update the facility
.. I TYP'="G" Q
.. S PRV="",TDEN=0,TNUM=0
.. F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" D
... I $P(^VA(200,PRV,0),U,13)'="" Q
... S IPRN=$O(^BQIPROV(PRV,30,"B",CODE,"")) I IPRN="" Q
... S IPRD=$O(^BQIPROV(PRV,30,IPRN,1,"B",BQDATE,"")) I IPRD="" Q
... S DEN=$P(^BQIPROV(PRV,30,IPRN,1,IPRD,0),U,2),NUM=$P(^(0),U,3)
... S TNUM=TNUM+NUM,TDEN=TDEN+DEN
... ;W !,PRV,"|",NUM,"|",DEN
.. ;W !,BQDATE,"|",CODE,"|",TNUM,"|",TDEN
.. S FAC=$$HME^BQIGPUTL()
.. D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
Q
;
ROW ;EP
;;3130900^62
;;3131000^63
;;3131100^64
;;3131200^65
;;3140100^66
;;3140200^67
;;3140300^68
;;3140400^69
;;3140500^70
;;3140600^71
;;3140700^72
;;3140800^73
;;3140900^74
;;3141000^75
;;3141100^76
;;3141200^77
Q
BQIIPCFX ;GDIT/HS/ALA-Fix IPC ; 02 Jan 2014 12:36 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;**5**;Apr 18, 2012;Build 17
+2 ;
+3 NEW BI,FROW,BQDATE,PRN,PROW
+4 FOR BI=1:1:16
SET FROW=$PIECE($TEXT(ROW+BI),";;",2)
Begin DoDot:1
+5 SET BQDATE=$PIECE(FROW,U,1)
SET ROW=$PIECE(FROW,U,2)
+6 SET PRN=$ORDER(^BQI(90508,1,22,2,3,"B",BQDATE,""))
IF PRN=""
QUIT
+7 SET PROW=$PIECE(^BQI(90508,1,22,2,3,PRN,0),U,2)
+8 IF PROW'=ROW
SET $PIECE(^BQI(90508,1,22,2,3,PRN,0),U,2)=ROW
End DoDot:1
+9 ;
+10 NEW ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSAVE,BQIUPD
+11 SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),,,3)
+12 SET ZTDESC="IPC Update Compile"
SET ZTRTN="JOB^BQIIPCFX"
SET ZTIO=""
+13 DO ^%ZTLOAD
+14 SET BQIUPD(90508,"1,",11.04)=ZTSK
+15 DO FILE^DIE("","BQIUPD","ERROR")
+16 QUIT
+17 ;
JOB ;EP
+1 IF '$DATA(^BQI(90508,1,22,2,3,"B",3141100))
Begin DoDot:1
+2 SET BQDATE=3141100
DO EN^BQIIPMNU
End DoDot:1
+3 IF '$DATA(^BQI(90508,1,22,2,3,"B",3141200))
Begin DoDot:1
+4 SET BQDATE=3141200
DO EN^BQIIPMNU
End DoDot:1
+5 IF '$DATA(^BQI(90508,1,22,2,3,"B",3150100))
DO IJB^BQINIGH3(3150100)
+6 ;
MU ;EP Fix MU
+1 NEW BQIPROV
+2 SET BQIPROV=0
+3 FOR
SET BQIPROV=$ORDER(^BQIPROV(BQIPROV))
IF 'BQIPROV
QUIT
Begin DoDot:1
+4 FOR CODE="MU_5","MU_6","MU_7","MU_8"
Begin DoDot:2
+5 SET MPDN=$ORDER(^BQIPROV(BQIPROV,30,"B",CODE,""))
IF MPDN=""
QUIT
+6 SET MPDT=3121200
+7 FOR
SET MPDT=$ORDER(^BQIPROV(BQIPROV,30,MPDN,1,"B",MPDT))
IF MPDT=""
QUIT
Begin DoDot:3
+8 SET BEGDT=$EXTRACT(MPDT,1,5)_"01"
SET CYR=$EXTRACT(MPDT,1,3)
SET BQMON=$EXTRACT(MPDT,4,5)
+9 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+10 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+11 SET ENDT=$EXTRACT(MPDT,1,5)_$PIECE(EDAY,U,+BQMON)
+12 SET BQDATE=MPDT
+13 DO MU^BQIIPSNG
End DoDot:3
End DoDot:2
+14 IF MPDN=""
QUIT
+15 SET BQDATE=3121200
+16 FOR
SET BQDATE=$ORDER(^BQIPROV(BQIPROV,30,MPDN,1,"B",BQDATE))
IF BQDATE=""
QUIT
Begin DoDot:2
+17 ; Update the MU bundles
+18 NEW MPRN,IPRN,IPRD,DEN,NUM,MCOD,MPRD,MBUN
+19 SET MPRN=$ORDER(^BQIPROV(BQIPROV,30,"B","IPC_WGT",""))
+20 IF MPRN'=""
SET MPRD=$ORDER(^BQIPROV(BQIPROV,30,MPRN,1,"B",BQDATE,""))
+21 KILL MBUN
+22 FOR MCOD="MU_8","MU_6","MU_7"
Begin DoDot:3
+23 SET IPRN=$ORDER(^BQIPROV(BQIPROV,30,"B",MCOD,""))
IF IPRN=""
QUIT
+24 SET IPRD=$ORDER(^BQIPROV(BQIPROV,30,IPRN,1,"B",BQDATE,""))
IF IPRD=""
QUIT
+25 SET DEN=$PIECE(^BQIPROV(BQIPROV,30,IPRN,1,IPRD,0),U,2)
SET NUM=$PIECE(^(0),U,3)
+26 SET MBUN(+DEN)=+NUM
End DoDot:3
+27 SET DEN=$ORDER(MBUN(""))
+28 IF DEN=""
SET NUM=""
IF DEN'=""
SET NUM=MBUN(DEN)
+29 IF MPRN'=""
IF MPRD'=""
Begin DoDot:3
+30 SET $PIECE(^BQIPROV(BQIPROV,30,MPRN,1,MPRD,0),U,2)=DEN
SET $PIECE(^BQIPROV(BQIPROV,30,MPRN,1,MPRD,0),U,3)=NUM
End DoDot:3
End DoDot:2
End DoDot:1
+31 ;
+32 FOR CODE="MU_5","MU_6","MU_7","MU_8","IPC_WGT"
Begin DoDot:1
+33 SET BPRV=0
KILL TDEN,TNUM
+34 FOR
SET BPRV=$ORDER(^BQIPROV(BPRV))
IF 'BPRV
QUIT
Begin DoDot:2
+35 SET MPDN=$ORDER(^BQIPROV(BPRV,30,"B",CODE,""))
IF MPDN=""
QUIT
+36 SET BDT=3131200
+37 FOR
SET BDT=$ORDER(^BQIPROV(BPRV,30,MPDN,1,"B",BDT))
IF BDT=""
QUIT
Begin DoDot:3
+38 SET MIEN=$ORDER(^BQIPROV(BPRV,30,MPDN,1,"B",BDT,""))
IF MIEN=""
QUIT
+39 SET DEN=$PIECE(^BQIPROV(BPRV,30,MPDN,1,MIEN,0),U,2)
SET NUM=$PIECE(^(0),U,3)
+40 SET TDEN(BDT)=$GET(TDEN(BDT))+DEN
SET TNUM(BDT)=$GET(TNUM(BDT))+NUM
End DoDot:3
End DoDot:2
+41 SET BDT=""
+42 FOR
SET BDT=$ORDER(TDEN(BDT))
IF BDT=""
QUIT
Begin DoDot:2
+43 SET FAC=$$HME^BQIGPUTL()
+44 DO STORF^BQIIPUTL(FAC,CODE,BDT,TDEN(BDT),TNUM(BDT))
End DoDot:2
+45 KILL TDEN,TNUM
End DoDot:1
+46 ;
+47 NEW BQD,BQX,BQDATE,CODE,PRV,TDEN,TNUM,IPRN,IPRD,DEN,NUM,FAC,Y
+48 SET BQD=3140800
+49 FOR
SET BQD=$ORDER(^BQI(90508,1,22,2,3,"B",BQD))
IF BQD=""
QUIT
SET BQX(BQD)=""
+50 SET BQDATE=""
+51 FOR
SET BQDATE=$ORDER(BQX(BQDATE))
IF BQDATE=""
QUIT
Begin DoDot:1
+52 SET MSN=0
SET CRN=2
+53 FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,MSN))
IF 'MSN
QUIT
Begin DoDot:2
+54 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+55 SET CODE=$PIECE(IDATA,U,1)
SET TYP=$PIECE(IDATA,U,2)
+56 ; If inactive, quit
+57 IF $PIECE(IDATA,U,7)=1
QUIT
+58 ; If type is CRS, update the facility
+59 IF TYP'="G"
QUIT
+60 SET PRV=""
SET TDEN=0
SET TNUM=0
+61 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:3
+62 IF $PIECE(^VA(200,PRV,0),U,13)'=""
QUIT
+63 SET IPRN=$ORDER(^BQIPROV(PRV,30,"B",CODE,""))
IF IPRN=""
QUIT
+64 SET IPRD=$ORDER(^BQIPROV(PRV,30,IPRN,1,"B",BQDATE,""))
IF IPRD=""
QUIT
+65 SET DEN=$PIECE(^BQIPROV(PRV,30,IPRN,1,IPRD,0),U,2)
SET NUM=$PIECE(^(0),U,3)
+66 SET TNUM=TNUM+NUM
SET TDEN=TDEN+DEN
+67 ;W !,PRV,"|",NUM,"|",DEN
End DoDot:3
+68 ;W !,BQDATE,"|",CODE,"|",TNUM,"|",TDEN
+69 SET FAC=$$HME^BQIGPUTL()
+70 DO STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
End DoDot:2
End DoDot:1
+71 QUIT
+72 ;
ROW ;EP
+1 ;;3130900^62
+2 ;;3131000^63
+3 ;;3131100^64
+4 ;;3131200^65
+5 ;;3140100^66
+6 ;;3140200^67
+7 ;;3140300^68
+8 ;;3140400^69
+9 ;;3140500^70
+10 ;;3140600^71
+11 ;;3140700^72
+12 ;;3140800^73
+13 ;;3140900^74
+14 ;;3141000^75
+15 ;;3141100^76
+16 ;;3141200^77
+17 QUIT
