- 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
