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
