BQIGPFX.m

BQIGPFX ;GDIT/HS/ALA-Fix IPC CRS Measures ; 24 Oct 2013  8:20 AM

 ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66

 ;

 ; If somehow the users installed Version 2.3 AFTER they had installed CRS 13.0, their values might

 ; still be 2012

 ;

EN(BQFYR,BQSYR) ;EP

 NEW BQIDA,BQIPC,BQCYR,BQIYR,CODE,BQN,BQIMEAS,BQSN,BQIINDG,BQGDATA0,BQNYR,BQNN

 NEW BQGDATA,ID,PRV,FC,BQPN,PCODE,BQIINDF,BQIMEASF

 S BQIDA=1,BQIPC=2,BQCYR=$P($G(^BQI(90508,BQIDA,"GPRA")),"^",1)

 ; If site has not installed CRS 13.0

 I BQCYR=2012 Q

 K ^XTMP("BQICRSUPD")

 S BQN=0

 F  S BQN=$O(^BQI(90508,BQIDA,22,BQIPC,1,BQN)) Q:'BQN  D

 . S CODE=$P(^BQI(90508,BQIDA,22,BQIPC,1,BQN,0),"^",1)

 . I $E(CODE,1,1)'=2 Q

 . S BQIYR=$P(CODE,"_",1),BQIMEAS=$P(CODE,"_",2)

 . ; if IPC year and CRS year match, quit

 . I BQCYR=BQIYR Q

 . ; if they still have 2012 BQFYR, convert to 2013 BQSYR

 . I BQIYR=BQFYR D

 .. S BQSN=$O(^BQI(90508,BQIDA,20,"B",BQIYR,"")) I BQSN="" Q

 .. D GFN^BQIGPUTL(BQIDA,BQSN)

 .. S BQIINDG=$$ROOT^DILFD(BQIMEASF,"",1)

 .. S BQGDATA0=$G(@BQIINDG@(BQIMEAS,0)),ID=$P(BQGDATA0,"^",4)

 .. S ^XTMP("BQICRSUPD",ID)=CODE_"^"_BQN

 ;

 S BQN=0

 F  S BQN=$O(^BQI(90508,BQIDA,22,BQIPC,1,BQN)) Q:'BQN  D

 . S CODE=$P(^BQI(90508,BQIDA,22,BQIPC,1,BQN,0),"^",1)

 . I $E(CODE,1,1)=2 Q

 . D BUN

 ;

 I '$D(^XTMP("BQICRSUPD")) Q

 ;

 S BQNYR=BQSYR

 S BQSN=$O(^BQI(90508,BQIDA,20,"B",BQNYR,"")) I BQSN="" Q

 D GFN^BQIGPUTL(BQIDA,BQSN)

 S BQIINDG=$$ROOT^DILFD(BQIMEASF,"",1)

 S BQNN=0

 F  S BQNN=$O(@BQIINDG@(BQNN)) Q:'BQNN  D

 . S BQGDATA=$G(@BQIINDG@(BQNN,17)),ID=$P(BQGDATA,"^",8) I ID="" Q

 . I $D(^XTMP("BQICRSUPD",ID)) S $P(^XTMP("BQICRSUPD",ID),"^",3)=BQSYR_"_"_BQNN

 ;

 S ID=""

 F  S ID=$O(^XTMP("BQICRSUPD",ID)) Q:ID=""  D

 . S BQN=$P(^XTMP("BQICRSUPD",ID),"^",2),CODE=$P(^XTMP("BQICRSUPD",ID),"^",3)

 . I CODE="" Q

 . S PCODE=$P(^XTMP("BQICRSUPD",ID),"^",1)

 . I BQN'[":" D

 .. NEW DA,IENS

 .. S DA(2)=BQIDA,DA(1)=BQIPC,DA=BQN,IENS=$$IENS^DILF(.DA)

 .. S BQIUPD(90508.221,IENS,.01)=CODE

 . I BQN[":" D

 .. NEW DA,IENS

 .. S DA(3)=BQIDA,DA(2)=BQIPC,DA(1)=$P(BQN,":",1),DA=$P(BQN,":",2),IENS=$$IENS^DILF(.DA)

 .. S BQIUPD(90508.2212,IENS,.01)=CODE

 . S PRV=0

 . F  S PRV=$O(^BQIPROV(PRV)) Q:'PRV  D

 .. S BQPN=$O(^BQIPROV(PRV,30,"B",PCODE,"")) I BQPN="" Q

 .. NEW DA,IENS

 .. S DA(1)=PRV,DA=BQPN,IENS=$$IENS^DILF(.DA)

 .. S BQIUPD(90505.43,IENS,.01)=CODE

 . S FC=0

 . F  S FC=$O(^BQIFAC(FC)) Q:'FC  D

 .. S BQPN=$O(^BQIFAC(FC,30,"B",PCODE,"")) I BQPN="" Q

 .. NEW DA,IENS

 .. S DA(1)=FC,DA=BQPN,IENS=$$IENS^DILF(.DA)

 .. S BQIUPD(90505.63,IENS,.01)=CODE

 D FILE^DIE("","BQIUPD","ERROR")

 Q

 ;

BUN ;EP Check bundles

 S BQBN=0

 F  S BQBN=$O(^BQI(90508,BQIDA,22,BQIPC,1,BQN,2,BQBN)) Q:'BQBN  D

 . S CODE=$P(^BQI(90508,BQIDA,22,BQIPC,1,BQN,2,BQBN,0),"^",1)

 . I $E(CODE,1,1)'=2 Q

 . S BQIYR=$P(CODE,"_",1),BQIMEAS=$P(CODE,"_",2)

 . I BQCYR=BQIYR Q

 . ; if they still have 2012 BQFYR, convert to 2013 BQSYR

 . I BQIYR=BQFYR D

 .. S BQSN=$O(^BQI(90508,BQIDA,20,"B",BQIYR,"")) I BQSN="" Q

 .. D GFN^BQIGPUTL(BQIDA,BQSN)

 .. S BQIINDG=$$ROOT^DILFD(BQIMEASF,"",1)

 .. S BQGDATA0=$G(@BQIINDG@(BQIMEAS,0)),ID=$P(BQGDATA0,"^",4)

 .. S ^XTMP("BQICRSUPD",ID)=CODE_"^"_BQN_":"_BQBN

 Q

BQIGPFX   ;GDIT/HS/ALA-Fix IPC CRS Measures ; 24 Oct 2013  8:20 AM

 +1       ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66

 +2       ;

 +3       ; If somehow the users installed Version 2.3 AFTER they had installed CRS 13.0, their values might

 +4       ; still be 2012

 +5       ;

EN(BQFYR,BQSYR) ;EP

 +1        NEW BQIDA,BQIPC,BQCYR,BQIYR,CODE,BQN,BQIMEAS,BQSN,BQIINDG,BQGDATA0,BQNYR,BQNN

 +2        NEW BQGDATA,ID,PRV,FC,BQPN,PCODE,BQIINDF,BQIMEASF

 +3        SET BQIDA=1

           SET BQIPC=2

           SET BQCYR=$PIECE($GET(^BQI(90508,BQIDA,"GPRA")),"^",1)

 +4       ; If site has not installed CRS 13.0

 +5        IF BQCYR=2012

               QUIT 

 +6        KILL ^XTMP("BQICRSUPD")

 +7        SET BQN=0

 +8        FOR 

               SET BQN=$ORDER(^BQI(90508,BQIDA,22,BQIPC,1,BQN))

               IF 'BQN

                   QUIT 

               Begin DoDot:1

 +9                SET CODE=$PIECE(^BQI(90508,BQIDA,22,BQIPC,1,BQN,0),"^",1)

 +10               IF $EXTRACT(CODE,1,1)'=2

                       QUIT 

 +11               SET BQIYR=$PIECE(CODE,"_",1)

                   SET BQIMEAS=$PIECE(CODE,"_",2)

 +12      ; if IPC year and CRS year match, quit

 +13               IF BQCYR=BQIYR

                       QUIT 

 +14      ; if they still have 2012 BQFYR, convert to 2013 BQSYR

 +15               IF BQIYR=BQFYR

                       Begin DoDot:2

 +16                       SET BQSN=$ORDER(^BQI(90508,BQIDA,20,"B",BQIYR,""))

                           IF BQSN=""

                               QUIT 

 +17                       DO GFN^BQIGPUTL(BQIDA,BQSN)

 +18                       SET BQIINDG=$$ROOT^DILFD(BQIMEASF,"",1)

 +19                       SET BQGDATA0=$GET(@BQIINDG@(BQIMEAS,0))

                           SET ID=$PIECE(BQGDATA0,"^",4)

 +20                       SET ^XTMP("BQICRSUPD",ID)=CODE_"^"_BQN

                       End DoDot:2

               End DoDot:1

 +21      ;

 +22       SET BQN=0

 +23       FOR 

               SET BQN=$ORDER(^BQI(90508,BQIDA,22,BQIPC,1,BQN))

               IF 'BQN

                   QUIT 

               Begin DoDot:1

 +24               SET CODE=$PIECE(^BQI(90508,BQIDA,22,BQIPC,1,BQN,0),"^",1)

 +25               IF $EXTRACT(CODE,1,1)=2

                       QUIT 

 +26               DO BUN

               End DoDot:1

 +27      ;

 +28       IF '$DATA(^XTMP("BQICRSUPD"))

               QUIT 

 +29      ;

 +30       SET BQNYR=BQSYR

 +31       SET BQSN=$ORDER(^BQI(90508,BQIDA,20,"B",BQNYR,""))

           IF BQSN=""

               QUIT 

 +32       DO GFN^BQIGPUTL(BQIDA,BQSN)

 +33       SET BQIINDG=$$ROOT^DILFD(BQIMEASF,"",1)

 +34       SET BQNN=0

 +35       FOR 

               SET BQNN=$ORDER(@BQIINDG@(BQNN))

               IF 'BQNN

                   QUIT 

               Begin DoDot:1

 +36               SET BQGDATA=$GET(@BQIINDG@(BQNN,17))

                   SET ID=$PIECE(BQGDATA,"^",8)

                   IF ID=""

                       QUIT 

 +37               IF $DATA(^XTMP("BQICRSUPD",ID))

                       SET $PIECE(^XTMP("BQICRSUPD",ID),"^",3)=BQSYR_"_"_BQNN

               End DoDot:1

 +38      ;

 +39       SET ID=""

 +40       FOR 

               SET ID=$ORDER(^XTMP("BQICRSUPD",ID))

               IF ID=""

                   QUIT 

               Begin DoDot:1

 +41               SET BQN=$PIECE(^XTMP("BQICRSUPD",ID),"^",2)

                   SET CODE=$PIECE(^XTMP("BQICRSUPD",ID),"^",3)

 +42               IF CODE=""

                       QUIT 

 +43               SET PCODE=$PIECE(^XTMP("BQICRSUPD",ID),"^",1)

 +44               IF BQN'[":"

                       Begin DoDot:2

 +45                       NEW DA,IENS

 +46                       SET DA(2)=BQIDA

                           SET DA(1)=BQIPC

                           SET DA=BQN

                           SET IENS=$$IENS^DILF(.DA)

 +47                       SET BQIUPD(90508.221,IENS,.01)=CODE

                       End DoDot:2

 +48               IF BQN[":"

                       Begin DoDot:2

 +49                       NEW DA,IENS

 +50                       SET DA(3)=BQIDA

                           SET DA(2)=BQIPC

                           SET DA(1)=$PIECE(BQN,":",1)

                           SET DA=$PIECE(BQN,":",2)

                           SET IENS=$$IENS^DILF(.DA)

 +51                       SET BQIUPD(90508.2212,IENS,.01)=CODE

                       End DoDot:2

 +52               SET PRV=0

 +53               FOR 

                       SET PRV=$ORDER(^BQIPROV(PRV))

                       IF 'PRV

                           QUIT 

                       Begin DoDot:2

 +54                       SET BQPN=$ORDER(^BQIPROV(PRV,30,"B",PCODE,""))

                           IF BQPN=""

                               QUIT 

 +55                       NEW DA,IENS

 +56                       SET DA(1)=PRV

                           SET DA=BQPN

                           SET IENS=$$IENS^DILF(.DA)

 +57                       SET BQIUPD(90505.43,IENS,.01)=CODE

                       End DoDot:2

 +58               SET FC=0

 +59               FOR 

                       SET FC=$ORDER(^BQIFAC(FC))

                       IF 'FC

                           QUIT 

                       Begin DoDot:2

 +60                       SET BQPN=$ORDER(^BQIFAC(FC,30,"B",PCODE,""))

                           IF BQPN=""

                               QUIT 

 +61                       NEW DA,IENS

 +62                       SET DA(1)=FC

                           SET DA=BQPN

                           SET IENS=$$IENS^DILF(.DA)

 +63                       SET BQIUPD(90505.63,IENS,.01)=CODE

                       End DoDot:2

               End DoDot:1

 +64       DO FILE^DIE("","BQIUPD","ERROR")

 +65       QUIT 

 +66      ;

BUN       ;EP Check bundles

 +1        SET BQBN=0

 +2        FOR 

               SET BQBN=$ORDER(^BQI(90508,BQIDA,22,BQIPC,1,BQN,2,BQBN))

               IF 'BQBN

                   QUIT 

               Begin DoDot:1

 +3                SET CODE=$PIECE(^BQI(90508,BQIDA,22,BQIPC,1,BQN,2,BQBN,0),"^",1)

 +4                IF $EXTRACT(CODE,1,1)'=2

                       QUIT 

 +5                SET BQIYR=$PIECE(CODE,"_",1)

                   SET BQIMEAS=$PIECE(CODE,"_",2)

 +6                IF BQCYR=BQIYR

                       QUIT 

 +7       ; if they still have 2012 BQFYR, convert to 2013 BQSYR

 +8                IF BQIYR=BQFYR

                       Begin DoDot:2

 +9                        SET BQSN=$ORDER(^BQI(90508,BQIDA,20,"B",BQIYR,""))

                           IF BQSN=""

                               QUIT 

 +10                       DO GFN^BQIGPUTL(BQIDA,BQSN)

 +11                       SET BQIINDG=$$ROOT^DILFD(BQIMEASF,"",1)

 +12                       SET BQGDATA0=$GET(@BQIINDG@(BQIMEAS,0))

                           SET ID=$PIECE(BQGDATA0,"^",4)

 +13                       SET ^XTMP("BQICRSUPD",ID)=CODE_"^"_BQN_":"_BQBN

                       End DoDot:2

               End DoDot:1

 +14       QUIT