Routine: BQIIPCCT

BQIIPCCT ;GDIT/HCSD/ALA-Continuity of Care Team ; 03 Oct 2017  9:37 AM

 ;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23

EN(BQDATE,BQFROM,BQTHRU) ;EP

 NEW BQDTE,BQMON,EDAY,ENDT,CYR,PYR,ID,FAC,BQITOTV,BQITOTR,BD,VISIT

 NEW DFN,VD,X,Y,BQA,DPCP,CLN,QFL,BEGDT,BQITOTP,FC,PRV,CRST,CRIPC,CRN

 NEW GLOB1,GLOB2,TOTP,TOTV,BQITOTM,GLOB3

 S QFL=0

 S CRST=$P($G(^BQI(90508,1,11)),U,2) S:CRST="" CRST=1

 S CRST="0"_CRST

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

 S CRIPC="IPCMH"

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

 S GLOB3=$NA(^XTMP("BQITEAM")) K @GLOB3

 S @GLOB3@(0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Team IPC Compilation"

 I $G(BQDATE)'="",$G(WEEK)="" D

 . S BEGDT=$E(BQDATE,1,5)_"01",CYR=$E(BQDATE,1,3),BQMON=$E(BQDATE,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(BQDATE,1,5)_$P(EDAY,U,+BQMON)

 I $G(BQDATE)="",$G(WEEK)="" D  Q:QFL

 . I $E(DT,6,7)'=CRST S QFL=1 Q

 . S BQMON=$E(DT,4,5)-1,CYR=$E(DT,1,3),PYR=CYR-1

 . S BQDTE=$P($T(BQM+BQMON),";;",2)

 . I $L(BQMON)=1 S BQMON="0"_BQMON

 . S BEGDT=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_"01"

 . S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"

 . S ENDT=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_$P(EDAY,U,+$P(BQDTE,U,1))

 . S BQDATE=$S(BQMON="01":PYR,1:CYR)_BQMON_"00"

 I $G(WEEK)="" D

 . S GLOB2=$NA(^XTMP("BQICCTM")) K @GLOB2

 . S @GLOB2@(0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Monthly Visits"

 I $G(WEEK)=1 D

 . S BEGDT=BQFROM-.9999,ENDT=BQTHRU,CRIPC="IPCMH",CRN=3

 . S GLOB2=$NA(^XTMP("BQICCTW")) K @GLOB2

 . S @GLOB2@(0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Weekly Visits"

 S ID="IPC_CCTM"

 ; check for divisions

 I $O(^BQI(90508,1,25,0))'="" D

 . S FAC="" F  S FAC=$O(^BQI(90508,1,25,"B",FAC)) Q:FAC=""  D

 .. D VIS K BQITOTM,@GLOB2

 .. D STOR

 I $O(^BQI(90508,1,25,0))="" S FAC=$$HME^BQIGPUTL() D

 . D VIS K BQITOTM,@GLOB2

 . D STOR

 S FAC=0,TNUM=0,TDEN=0

 F  S FAC=$O(@GLOB3@(FAC)) Q:FAC=""  D

 . S TEAM=""

 . F  S TEAM=$O(@GLOB3@(FAC,TEAM)) Q:TEAM=""  D

 .. I $P(@GLOB3@(FAC,TEAM),"^",1)=0,$P(@GLOB3@(FAC,TEAM),"^",2)=0 Q

 .. I $G(DEBUG)=1 W !,FAC,"|",TEAM,"|",@GLOB3@(FAC,TEAM)

 .. ;S TNUM=TNUM+$P(@GLOB3@(FAC,TEAM),"^",1),TDEN=TDEN+$P(@GLOB3@(FAC,TEAM),"^",2)

 .. S TNUM=TNUM+$P(@GLOB3@(FAC,TEAM),"^",1),TDEN=$P(@GLOB3@(FAC,TEAM),"^",2)

 .. I $G(WEEK)="" D STORT^BQIIPUTL(TEAM,ID,BQDATE,$P(@GLOB3@(FAC,TEAM),"^",2),$P(@GLOB3@(FAC,TEAM),"^",1))

 .. I $G(WEEK)=1 D STORTW^BQIIPUTL(TEAM,ID,BQFROM,BQTHRU,$P(@GLOB3@(FAC,TEAM),"^",2),$P(@GLOB3@(FAC,TEAM),"^",1))

 S FAC=$$HME^BQIGPUTL(),ID="IPC_CCTM"

 I $G(WEEK)="" D STORF^BQIIPUTL(FAC,ID,BQDATE,TDEN,TNUM)

 I $G(WEEK)=1 D STORFW^BQIIPUTL(FAC,ID,BQFROM,BQTHRU,TDEN,TNUM)

STOR ;Store the data

 S TMN=0 F  S TMN=$O(^BSDPCT(TMN)) Q:'TMN  D

 . S TEAM=$P(^BSDPCT(TMN,0),"^",1)

 . I '$D(@GLOB3@(FAC,TEAM)) S @GLOB3@(FAC,TEAM)="0^0"

VIS ; Find visits

 S BQITOTV=0,BQITOTR=0

 D TMS

 S BD=BEGDT

 F  S BD=$O(^AUPNVSIT("B",BD)) Q:BD=""!(BD\1>ENDT)  D

 . S VISIT=""

 . F  S VISIT=$O(^AUPNVSIT("B",BD,VISIT)) Q:VISIT=""  D

 .. I $G(^AUPNVSIT(VISIT,0))="" Q

 .. I $P(^AUPNVSIT(VISIT,0),U,11) Q

 .. ; skip E:EVENT (HISTORICAL);D:DAILY HOSP DATA;X:ANCILLARY PACKAGE DAILY visits

 .. Q:"EDX"[$P(^AUPNVSIT(VISIT,0),U,7)

 .. ; location of visit not facility

 .. S FC=$P(^AUPNVSIT(VISIT,0),U,6) Q:'FC

 .. Q:FC'=FAC

 .. ; if no diagnoses

 .. Q:'$D(^AUPNVPOV("AD",VISIT))

 .. S DFN=$P(^AUPNVSIT(VISIT,0),U,5) I DFN="" Q

 .. I $G(^AUPNPAT(DFN,0))="" Q

 .. I $G(^DPT(DFN,0))="" Q

 .. ; If no HRN for this facility

 .. I $G(^AUPNPAT(DFN,41,FAC,0))="" Q

 .. S VD=$P(^AUPNVSIT(VISIT,0),U,1)\1

 .. ; HRN is inactive

 .. S X=$S($P($G(^AUPNPAT(DFN,41,FAC,0)),U,3)="":1,$P($G(^AUPNPAT(DFN,41,FAC,0)),U,3)>VD:1,1:0)

 .. I 'X Q

 .. ; patient is deceased

 .. I $P($G(^DPT(DFN,.35)),U,1)'="" Q

 .. ; If no DPCP

 .. S DPCP=$P(^AUPNPAT(DFN,0),U,14) I DPCP="" Q

 .. S CLN=$P(^AUPNVSIT(VISIT,0),U,8) I CLN="" Q

 .. ; check against primary care clinic list

 .. I '$D(^BQI(90508,1,23,"B",CLN)) Q

 .. ; No primary provider

 .. S BQA=$$PRIMPROV^APCLV(VISIT,"I") I BQA="" Q

 .. S BQITOTV=BQITOTV+1 ; Denominator

 .. ; primary provider of visit

 .. S @GLOB2@(DFN,BQA)=""

 D TMB

 S TEAM=""

 F  S TEAM=$O(BQITOTM(FAC,TEAM)) Q:TEAM=""  D

 . I $P(BQITOTM(FAC,TEAM),"^",1)'=0 S $P(BQITOTM(FAC,TEAM),"^",2)=BQITOTV,@GLOB3@(FAC,TEAM)=BQITOTM(FAC,TEAM)

TMS ;EP - Team setup

 I $G(WEEK)="" D

 . K ^XTMP("BQITEAMM")

 . S ^XTMP("BQITEAMM",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Monthly Compile"

 . S GLOB1=$NA(^XTMP("BQITEAMM"))

 I $G(WEEK)=1 D

 . K ^XTMP("BQITEAMW")

 . S ^XTMP("BQITEAMW",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Weekly Compile"

 . S GLOB1=$NA(^XTMP("BQITEAMW"))

 S TMN=0 F  S TMN=$O(^BSDPCT(TMN)) Q:'TMN  D

 . S TEAM=$P(^BSDPCT(TMN,0),"^",1)

 . S BQITOTM(FAC,TEAM)="0^0"

 . S TMM="" F  S TMM=$O(^BSDPCT(TMN,1,"B",TMM)) Q:TMM=""  D

 .. S DFN="" F  S DFN=$O(^AUPNPAT("AK",TMM,DFN)) Q:DFN=""  S @GLOB1@(FAC,TEAM,DFN)=""

TMB ;EP - Is provider member of a team?

 S DFN=0,TOTP=0,TOTV=0

 F  S DFN=$O(@GLOB2@(DFN)) Q:DFN=""  D

 . S PRV=""

 . F  S PRV=$O(@GLOB2@(DFN,PRV)) Q:PRV=""  D

 .. S TOTP=$G(TOTP)+1

 .. S TMN=$O(^BSDPCT("AB",PRV,"")) I TMN="" Q

 .. S TEAM=$P(^BSDPCT(TMN,0),"^",1)

 .. I $D(@GLOB1@(FAC,TEAM,DFN)) S $P(BQITOTM(FAC,TEAM),"^",1)=$P($G(BQITOTM(FAC,TEAM)),"^",1)+1

 .. S TOTV=TOTV+1

BQM ;

 ;;12^PYR

 ;;01^CYR

 ;;02^CYR

 ;;03^CYR

 ;;04^CYR

 ;;05^CYR

 ;;06^CYR

 ;;07^CYR

 ;;08^CYR

 ;;09^CYR

 ;;10^CYR

 ;;11^CYR

BQIIPCCT  ;GDIT/HCSD/ALA-Continuity of Care Team ; 03 Oct 2017  9:37 AM

 +1       ;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23

 +2       ;

 +3       ;

EN(BQDATE,BQFROM,BQTHRU) ;EP

 +1        NEW BQDTE,BQMON,EDAY,ENDT,CYR,PYR,ID,FAC,BQITOTV,BQITOTR,BD,VISIT

 +2        NEW DFN,VD,X,Y,BQA,DPCP,CLN,QFL,BEGDT,BQITOTP,FC,PRV,CRST,CRIPC,CRN

 +3        NEW GLOB1,GLOB2,TOTP,TOTV,BQITOTM,GLOB3

 +4       ;

 +5        SET QFL=0

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

           IF CRST=""

               SET CRST=1

 +7        SET CRST="0"_CRST

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

 +9        SET CRIPC="IPCMH"

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

           IF CRN=""

               QUIT

 +11       SET GLOB3=$NAME(^XTMP("BQITEAM"))

           KILL @GLOB3

 +12       SET @GLOB3@(0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Team IPC Compilation"

 +13      ;

 +14       IF $GET(BQDATE)'=""

               IF $GET(WEEK)=""

                   Begin DoDot:1

 +15                   SET BEGDT=$EXTRACT(BQDATE,1,5)_"01"

                       SET CYR=$EXTRACT(BQDATE,1,3)

                       SET BQMON=$EXTRACT(BQDATE,4,5)

 +16                   IF $LENGTH(BQMON)=1

                           SET BQMON="0"_BQMON

 +17                   SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"

 +18                   SET ENDT=$EXTRACT(BQDATE,1,5)_$PIECE(EDAY,U,+BQMON)

                   End DoDot:1

 +19      ;

 +20       IF $GET(BQDATE)=""

               IF $GET(WEEK)=""

                   Begin DoDot:1

 +21                   IF $EXTRACT(DT,6,7)'=CRST

                           SET QFL=1

                           QUIT

 +22                   SET BQMON=$EXTRACT(DT,4,5)-1

                       SET CYR=$EXTRACT(DT,1,3)

                       SET PYR=CYR-1

 +23                   SET BQDTE=$PIECE($TEXT(BQM+BQMON),";;",2)

 +24                   IF $LENGTH(BQMON)=1

                           SET BQMON="0"_BQMON

 +25                   SET BEGDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_"01"

 +26                   SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"

 +27                   SET ENDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_$PIECE(EDAY,U,+$PIECE(BQDTE,U,1))

 +28                   SET BQDATE=$SELECT(BQMON="01":PYR,1:CYR)_BQMON_"00"

                   End DoDot:1

                   IF QFL

                       QUIT

 +29      ;

 +30       IF $GET(WEEK)=""

               Begin DoDot:1

 +31               SET GLOB2=$NAME(^XTMP("BQICCTM"))

                   KILL @GLOB2

 +32               SET @GLOB2@(0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Monthly Visits"

               End DoDot:1

 +33       IF $GET(WEEK)=1

               Begin DoDot:1

 +34               SET BEGDT=BQFROM-.9999

                   SET ENDT=BQTHRU

                   SET CRIPC="IPCMH"

                   SET CRN=3

 +35               SET GLOB2=$NAME(^XTMP("BQICCTW"))

                   KILL @GLOB2

 +36               SET @GLOB2@(0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Weekly Visits"

               End DoDot:1

 +37      ;

 +38       SET ID="IPC_CCTM"

 +39      ;

 +40      ; check for divisions

 +41       IF $ORDER(^BQI(90508,1,25,0))'=""

               Begin DoDot:1

 +42               SET FAC=""

FOR

                       SET FAC=$ORDER(^BQI(90508,1,25,"B",FAC))

                       IF FAC=""

                           QUIT

                       Begin DoDot:2

 +43                       DO VIS

                           KILL BQITOTM,@GLOB2

 +44                       DO STOR

                       End DoDot:2

               End DoDot:1

 +45      ;

 +46       IF $ORDER(^BQI(90508,1,25,0))=""

               SET FAC=$$HME^BQIGPUTL()

               Begin DoDot:1

 +47               DO VIS

                   KILL BQITOTM,@GLOB2

 +48               DO STOR

               End DoDot:1

 +49      ;

 +50       SET FAC=0

           SET TNUM=0

           SET TDEN=0

 +51       FOR

               SET FAC=$ORDER(@GLOB3@(FAC))

               IF FAC=""

                   QUIT

               Begin DoDot:1

 +52               SET TEAM=""

 +53               FOR

                       SET TEAM=$ORDER(@GLOB3@(FAC,TEAM))

                       IF TEAM=""

                           QUIT

                       Begin DoDot:2

 +54                       IF $PIECE(@GLOB3@(FAC,TEAM),"^",1)=0

                               IF $PIECE(@GLOB3@(FAC,TEAM),"^",2)=0

                                   QUIT

 +55                       IF $GET(DEBUG)=1

                               WRITE !,FAC,"|",TEAM,"|",@GLOB3@(FAC,TEAM)

 +56      ;S TNUM=TNUM+$P(@GLOB3@(FAC,TEAM),"^",1),TDEN=TDEN+$P(@GLOB3@(FAC,TEAM),"^",2)

 +57                       SET TNUM=TNUM+$PIECE(@GLOB3@(FAC,TEAM),"^",1)

                           SET TDEN=$PIECE(@GLOB3@(FAC,TEAM),"^",2)

 +58                       IF $GET(WEEK)=""

                               DO STORT^BQIIPUTL(TEAM,ID,BQDATE,$PIECE(@GLOB3@(FAC,TEAM),"^",2),$PIECE(@GLOB3@(FAC,TEAM),"^",1))

 +59                       IF $GET(WEEK)=1

                               DO STORTW^BQIIPUTL(TEAM,ID,BQFROM,BQTHRU,$PIECE(@GLOB3@(FAC,TEAM),"^",2),$PIECE(@GLOB3@(FAC,TEAM),"^",1))

                       End DoDot:2

               End DoDot:1

 +60      ;

 +61       SET FAC=$$HME^BQIGPUTL()

           SET ID="IPC_CCTM"

 +62       IF $GET(WEEK)=""

               DO STORF^BQIIPUTL(FAC,ID,BQDATE,TDEN,TNUM)

 +63       IF $GET(WEEK)=1

               DO STORFW^BQIIPUTL(FAC,ID,BQFROM,BQTHRU,TDEN,TNUM)

 +64       QUIT

 +65      ;

STOR      ;Store the data

 +1        SET TMN=0

FOR

               SET TMN=$ORDER(^BSDPCT(TMN))

               IF 'TMN

                   QUIT

               Begin DoDot:1

 +2                SET TEAM=$PIECE(^BSDPCT(TMN,0),"^",1)

 +3                IF '$DATA(@GLOB3@(FAC,TEAM))

                       SET @GLOB3@(FAC,TEAM)="0^0"

               End DoDot:1

 +4        QUIT

 +5       ;

VIS       ; Find visits

 +1        SET BQITOTV=0

           SET BQITOTR=0

 +2        DO TMS

 +3       ;

 +4        SET BD=BEGDT

 +5        FOR

               SET BD=$ORDER(^AUPNVSIT("B",BD))

               IF BD=""!(BD\1>ENDT)

                   QUIT

               Begin DoDot:1

 +6                SET VISIT=""

 +7                FOR

                       SET VISIT=$ORDER(^AUPNVSIT("B",BD,VISIT))

                       IF VISIT=""

                           QUIT

                       Begin DoDot:2

 +8                        IF $GET(^AUPNVSIT(VISIT,0))=""

                               QUIT

 +9                        IF $PIECE(^AUPNVSIT(VISIT,0),U,11)

                               QUIT

 +10      ; skip E:EVENT (HISTORICAL);D:DAILY HOSP DATA;X:ANCILLARY PACKAGE DAILY visits

 +11                       IF "EDX"[$PIECE(^AUPNVSIT(VISIT,0),U,7)

                               QUIT

 +12      ; location of visit not facility

 +13                       SET FC=$PIECE(^AUPNVSIT(VISIT,0),U,6)

                           IF 'FC

                               QUIT

 +14                       IF FC'=FAC

                               QUIT

 +15      ; if no diagnoses

 +16                       IF '$DATA(^AUPNVPOV("AD",VISIT))

                               QUIT

 +17                       SET DFN=$PIECE(^AUPNVSIT(VISIT,0),U,5)

                           IF DFN=""

                               QUIT

 +18                       IF $GET(^AUPNPAT(DFN,0))=""

                               QUIT

 +19                       IF $GET(^DPT(DFN,0))=""

                               QUIT

 +20      ; If no HRN for this facility

 +21                       IF $GET(^AUPNPAT(DFN,41,FAC,0))=""

                               QUIT

 +22                       SET VD=$PIECE(^AUPNVSIT(VISIT,0),U,1)\1

 +23      ; HRN is inactive

 +24                       SET X=$SELECT($PIECE($GET(^AUPNPAT(DFN,41,FAC,0)),U,3)="":1,$PIECE($GET(^AUPNPAT(DFN,41,FAC,0)),U,3)>VD:1,1:0)

 +25                       IF 'X

                               QUIT

 +26      ; patient is deceased

 +27                       IF $PIECE($GET(^DPT(DFN,.35)),U,1)'=""

                               QUIT

 +28      ; If no DPCP

 +29                       SET DPCP=$PIECE(^AUPNPAT(DFN,0),U,14)

                           IF DPCP=""

                               QUIT

 +30                       SET CLN=$PIECE(^AUPNVSIT(VISIT,0),U,8)

                           IF CLN=""

                               QUIT

 +31      ; check against primary care clinic list

 +32                       IF '$DATA(^BQI(90508,1,23,"B",CLN))

                               QUIT

 +33      ; No primary provider

 +34                       SET BQA=$$PRIMPROV^APCLV(VISIT,"I")

                           IF BQA=""

                               QUIT

 +35      ; Denominator

                           SET BQITOTV=BQITOTV+1

 +36      ; primary provider of visit

 +37                       SET @GLOB2@(DFN,BQA)=""

                       End DoDot:2

               End DoDot:1

 +38      ;

 +39       DO TMB

 +40       SET TEAM=""

 +41       FOR

               SET TEAM=$ORDER(BQITOTM(FAC,TEAM))

               IF TEAM=""

                   QUIT

               Begin DoDot:1

 +42               IF $PIECE(BQITOTM(FAC,TEAM),"^",1)'=0

                       SET $PIECE(BQITOTM(FAC,TEAM),"^",2)=BQITOTV

                       SET @GLOB3@(FAC,TEAM)=BQITOTM(FAC,TEAM)

               End DoDot:1

 +43       QUIT

 +44      ;

TMS       ;EP - Team setup

 +1        IF $GET(WEEK)=""

               Begin DoDot:1

 +2                KILL ^XTMP("BQITEAMM")

 +3                SET ^XTMP("BQITEAMM",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Monthly Compile"

 +4                SET GLOB1=$NAME(^XTMP("BQITEAMM"))

               End DoDot:1

 +5        IF $GET(WEEK)=1

               Begin DoDot:1

 +6                KILL ^XTMP("BQITEAMW")

 +7                SET ^XTMP("BQITEAMW",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Weekly Compile"

 +8                SET GLOB1=$NAME(^XTMP("BQITEAMW"))

               End DoDot:1

 +9       ;

 +10       SET TMN=0

FOR

               SET TMN=$ORDER(^BSDPCT(TMN))

               IF 'TMN

                   QUIT

               Begin DoDot:1

 +11               SET TEAM=$PIECE(^BSDPCT(TMN,0),"^",1)

 +12               SET BQITOTM(FAC,TEAM)="0^0"

 +13               SET TMM=""

FOR

                       SET TMM=$ORDER(^BSDPCT(TMN,1,"B",TMM))

                       IF TMM=""

                           QUIT

                       Begin DoDot:2

 +14                       SET DFN=""

FOR

                               SET DFN=$ORDER(^AUPNPAT("AK",TMM,DFN))

                               IF DFN=""

                                   QUIT

                               SET @GLOB1@(FAC,TEAM,DFN)=""

                       End DoDot:2

               End DoDot:1

 +15       QUIT

 +16      ;

TMB       ;EP - Is provider member of a team?

 +1        SET DFN=0

           SET TOTP=0

           SET TOTV=0

 +2        FOR

               SET DFN=$ORDER(@GLOB2@(DFN))

               IF DFN=""

                   QUIT

               Begin DoDot:1

 +3                SET PRV=""

 +4                FOR

                       SET PRV=$ORDER(@GLOB2@(DFN,PRV))

                       IF PRV=""

                           QUIT

                       Begin DoDot:2

 +5                        SET TOTP=$GET(TOTP)+1

 +6                        SET TMN=$ORDER(^BSDPCT("AB",PRV,""))

                           IF TMN=""

                               QUIT

 +7                        SET TEAM=$PIECE(^BSDPCT(TMN,0),"^",1)

 +8                        IF $DATA(@GLOB1@(FAC,TEAM,DFN))

                               SET $PIECE(BQITOTM(FAC,TEAM),"^",1)=$PIECE($GET(BQITOTM(FAC,TEAM)),"^",1)+1

 +9                        SET TOTV=TOTV+1

                       End DoDot:2

               End DoDot:1

 +10       QUIT

 +11      ;

BQM       ;

 +1       ;;12^PYR

 +2       ;;01^CYR

 +3       ;;02^CYR

 +4       ;;03^CYR

 +5       ;;04^CYR

 +6       ;;05^CYR

 +7       ;;06^CYR

 +8       ;;07^CYR

 +9       ;;08^CYR

 +10      ;;09^CYR

 +11      ;;10^CYR

 +12      ;;11^CYR

BQIIPCCT.m