BQIIPUPD.m

BQIIPUPD ;VNGT/HS/ALA-IPC Update ; 26 May 2011  7:39 AM

 ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59

 ;

 ;

NCRS ;New CRS

 ; Change BQIGPUPD to change IPC Versions when new version of CRS is released

 ; take current IPC value and add one

 NEW CRIPC,NUM,NWIPC,DA,DIC,Y

 S CRIPC=$P($G(^BQI(90508,1,11)),U,1)

 F I=$L(CRIPC):-1:1 Q:$E(CRIPC,I,I)'?.N

 S NUM=$E(CRIPC,I+1,$L(CRIPC)),NUM=NUM+1

 S NWIPC="IPC"_NUM

 S DA(1)=1,X=NWIPC,DIC="^BQI(90508,"_DA(1)_",22,",DIC(0)="LMNZ",DLAYGO=90508.022

 I $G(^BQI(90508,1,22,0))="" S ^BQI(90508,1,22,0)="^90508.022^^"

 D ^DIC

 S $P(^BQI(90508,1,11),U,1)=NWIPC

 Q

 ;

CCRS ;Current CRS

 NEW CRIPC,CRN

 S CRIPC=$P($G(^BQI(90508,1,11)),U,1)

 S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q

 I $G(^BQI(90508,1,22,CRN,1,0))="" S ^BQI(90508,1,22,CRN,1,0)="^90508.221^^"

 ; Add new entries

 NEW BI,BJ,BK,BN,BQIUPD,ERROR,IENS,ND,NDATA,TEXT,VAL

 F BI=1:1 S TEXT=$P($T(NONC+BI),";;",2) Q:TEXT=""  D

 . F BJ=1:1:$L(TEXT,"~") D

 .. S NDATA=$P(TEXT,"~",BJ)

 .. S ND=$P(NDATA,"|",1),VAL=$P(NDATA,"|",2)

 .. I ND=0 D

 ... NEW DIC,X,Y,DA

 ... S DA(2)=1,DA(1)=CRN

 ... S DIC(0)="LQZ",DIC="^BQI(90508,"_DA(2)_",22,"_DA(1)_",1,",X=$P(VAL,U,1)

 ... D ^DIC

 ... S DA=+Y

 ... I DA=-1 K DO,DD D FILE^DICN S DA=+Y

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

 .. I ND=1 S BQIUPD(90508.221,IENS,1)=VAL Q

 .. F BK=1:1:$L(VAL,"^") D

 ... S BN=$O(^DD(90508.221,"GL",ND,BK,"")) I BN="" Q

 ... I $P(VAL,"^",BK)'="" S BQIUPD(90508.221,IENS,BN)=$P(VAL,"^",BK) Q

 ... I $P(VAL,"^",BK)="" S BQIUPD(90508.221,IENS,BN)="@"

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

 ;

GP ; Get fields from CRS

 NEW BQIH,BQIYR,BQIYDA,BQIMEASF,IDIN,MDATA,VAL

 S BQIH=$$SPM^BQIGPUTL()

 S BQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")

 S BQIYDA=$$LKP^BQIGPUTL(BQIYR)

 D GFN^BQIGPUTL(BQIH,BQIYDA)

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

 S IDIN=0

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

 . S MDATA=$G(@BQIINDG@(IDIN,17)) I MDATA="" Q

 . I +MDATA=0 Q

 . I $P(MDATA,U,7)'=1 Q

 . S VAL=BQIYR_"_"_IDIN

 . D NE(VAL)

 . S BQIUPD(90508.221,IENS,.02)="G",BQIUPD(90508.221,IENS,.04)=$P(MDATA,U,3)

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

 Q

 ;

NE(VALUE) ; New Entry

 NEW DIC,X,Y,DA

 S DA(2)=1,DA(1)=CRN

 S DIC(0)="LQZ",DIC="^BQI(90508,"_DA(2)_",22,"_DA(1)_",1,",X=$P(VALUE,U,1)

 D ^DIC

 S DA=+Y

 I DA=-1 K DO,DD D FILE^DICN S DA=+Y

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

 Q

 ;

NONC ; Non CRS definitions

 ;;0|IPC_REVG^R^S^Revenue Generated Per Visit~1|D EN^BQIIPRVG

 ;;0|IPC_CCPR^R^S^Continuity of Care Primary Provider~1|D EN^BQIIPCCP

 ;;0|IPC_PEMP^R^S^Empanelled Primary Care Provider~1|D EN^BQIIPEMP

 ;;0|IPC_CANC^R^C^Cancer Screening Bundle~1|

 ;;0|IPC_HRISK^R^H^Health Risk Screening Bundle~1|

 ;;0|IPC_OUTC^R^O^Outcome Measures Bundle~1|

BQIIPUPD  ;VNGT/HS/ALA-IPC Update ; 26 May 2011  7:39 AM

 +1       ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59

 +2       ;

 +3       ;

NCRS      ;New CRS

 +1       ; Change BQIGPUPD to change IPC Versions when new version of CRS is released

 +2       ; take current IPC value and add one

 +3        NEW CRIPC,NUM,NWIPC,DA,DIC,Y

 +4        SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)

 +5        FOR I=$LENGTH(CRIPC):-1:1

               IF $EXTRACT(CRIPC,I,I)'?.N

                   QUIT 

 +6        SET NUM=$EXTRACT(CRIPC,I+1,$LENGTH(CRIPC))

           SET NUM=NUM+1

 +7        SET NWIPC="IPC"_NUM

 +8        SET DA(1)=1

           SET X=NWIPC

           SET DIC="^BQI(90508,"_DA(1)_",22,"

           SET DIC(0)="LMNZ"

           SET DLAYGO=90508.022

 +9        IF $GET(^BQI(90508,1,22,0))=""

               SET ^BQI(90508,1,22,0)="^90508.022^^"

 +10       DO ^DIC

 +11       SET $PIECE(^BQI(90508,1,11),U,1)=NWIPC

 +12       QUIT 

 +13      ;

CCRS      ;Current CRS

 +1        NEW CRIPC,CRN

 +2        SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)

 +3        SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))

           IF CRN=""

               QUIT 

 +4        IF $GET(^BQI(90508,1,22,CRN,1,0))=""

               SET ^BQI(90508,1,22,CRN,1,0)="^90508.221^^"

 +5       ; Add new entries

 +6        NEW BI,BJ,BK,BN,BQIUPD,ERROR,IENS,ND,NDATA,TEXT,VAL

 +7        FOR BI=1:1

               SET TEXT=$PIECE($TEXT(NONC+BI),";;",2)

               IF TEXT=""

                   QUIT 

               Begin DoDot:1

 +8                FOR BJ=1:1:$LENGTH(TEXT,"~")

                       Begin DoDot:2

 +9                        SET NDATA=$PIECE(TEXT,"~",BJ)

 +10                       SET ND=$PIECE(NDATA,"|",1)

                           SET VAL=$PIECE(NDATA,"|",2)

 +11                       IF ND=0

                               Begin DoDot:3

 +12                               NEW DIC,X,Y,DA

 +13                               SET DA(2)=1

                                   SET DA(1)=CRN

 +14                               SET DIC(0)="LQZ"

                                   SET DIC="^BQI(90508,"_DA(2)_",22,"_DA(1)_",1,"

                                   SET X=$PIECE(VAL,U,1)

 +15                               DO ^DIC

 +16                               SET DA=+Y

 +17                               IF DA=-1

                                       KILL DO,DD

                                       DO FILE^DICN

                                       SET DA=+Y

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

                               End DoDot:3

 +19                       IF ND=1

                               SET BQIUPD(90508.221,IENS,1)=VAL

                               QUIT 

 +20                       FOR BK=1:1:$LENGTH(VAL,"^")

                               Begin DoDot:3

 +21                               SET BN=$ORDER(^DD(90508.221,"GL",ND,BK,""))

                                   IF BN=""

                                       QUIT 

 +22                               IF $PIECE(VAL,"^",BK)'=""

                                       SET BQIUPD(90508.221,IENS,BN)=$PIECE(VAL,"^",BK)

                                       QUIT 

 +23                               IF $PIECE(VAL,"^",BK)=""

                                       SET BQIUPD(90508.221,IENS,BN)="@"

                               End DoDot:3

                       End DoDot:2

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

               End DoDot:1

 +25      ;

GP        ; Get fields from CRS

 +1        NEW BQIH,BQIYR,BQIYDA,BQIMEASF,IDIN,MDATA,VAL

 +2        SET BQIH=$$SPM^BQIGPUTL()

 +3        SET BQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")

 +4        SET BQIYDA=$$LKP^BQIGPUTL(BQIYR)

 +5        DO GFN^BQIGPUTL(BQIH,BQIYDA)

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

 +7        SET IDIN=0

 +8        FOR 

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

               IF 'IDIN

                   QUIT 

               Begin DoDot:1

 +9                SET MDATA=$GET(@BQIINDG@(IDIN,17))

                   IF MDATA=""

                       QUIT 

 +10               IF +MDATA=0

                       QUIT 

 +11               IF $PIECE(MDATA,U,7)'=1

                       QUIT 

 +12               SET VAL=BQIYR_"_"_IDIN

 +13               DO NE(VAL)

 +14               SET BQIUPD(90508.221,IENS,.02)="G"

                   SET BQIUPD(90508.221,IENS,.04)=$PIECE(MDATA,U,3)

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

               End DoDot:1

 +16       QUIT 

 +17      ;

NE(VALUE) ; New Entry

 +1        NEW DIC,X,Y,DA

 +2        SET DA(2)=1

           SET DA(1)=CRN

 +3        SET DIC(0)="LQZ"

           SET DIC="^BQI(90508,"_DA(2)_",22,"_DA(1)_",1,"

           SET X=$PIECE(VALUE,U,1)

 +4        DO ^DIC

 +5        SET DA=+Y

 +6        IF DA=-1

               KILL DO,DD

               DO FILE^DICN

               SET DA=+Y

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

 +8        QUIT 

 +9       ;

NONC      ; Non CRS definitions

 +1       ;;0|IPC_REVG^R^S^Revenue Generated Per Visit~1|D EN^BQIIPRVG

 +2       ;;0|IPC_CCPR^R^S^Continuity of Care Primary Provider~1|D EN^BQIIPCCP

 +3       ;;0|IPC_PEMP^R^S^Empanelled Primary Care Provider~1|D EN^BQIIPEMP

 +4       ;;0|IPC_CANC^R^C^Cancer Screening Bundle~1|

 +5       ;;0|IPC_HRISK^R^H^Health Risk Screening Bundle~1|

 +6       ;;0|IPC_OUTC^R^O^Outcome Measures Bundle~1|