BQIIPBNL ;VNGT/HS/ALA-IPC Bundle Logic ; 24 Jun 2011 11:53 AM
;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
;
;
EN(CRSN,BNIEN,BQDATE,CODE,BQFROM,BQTHRU) ;EP - do the bundle for monthly update
; Input
; CRSN - Current IPC IEN
; BNIEN - Bundle IEN
; CODE - Code name
; BQI(90508,1,22,CRN,1,MSN,1
;
NEW TDEN,TNUM,CNT,CD,BQIDOD,NA,YES,NO,NDA
S BQDATE=$G(BQDATE,""),BQFROM=$G(BQFROM,""),BQTHRU=$G(BQTHRU,"")
S TDEN=0,TNUM=0,CNT=0
K XX
D BUN(CRSN,BNIEN,.XX)
S CD="" F S CD=$O(XX(CD)) Q:CD="" S CNT=CNT+1
;
S PRV=""
F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" D
. I $P(^VA(200,PRV,0),U,13)'="" Q
. S DFN="",PCT=0,TP=0
. F S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN="" D
.. ;B:PRV=2911
.. I '$$HRN^BQIUL1(DFN) Q
.. S VAL=$$PAT(DFN,.XX)
.. I VAL="N/A"!(VAL="{D}") Q
.. S TP=TP+1
.. I VAL="YES" S PCT=PCT+1
.. Q
.. S CD="",BCT=0,NA=0,YES=0,NO=0,NDA=0
.. F S CD=$O(XX(CD)) Q:CD="" D
... S IEN=$O(^BQIPAT(DFN,30,"B",CD,"")) I IEN="" S NDA=NDA+1 Q
... S BQIDOD=$$GET1^DIQ(2,DFN_",",.351,"I")
... I BQIDOD'="" Q
... S NUM=$P(^BQIPAT(DFN,30,IEN,0),U,3)
... S DEN=$P(^BQIPAT(DFN,30,IEN,0),U,4)
... S TP=TP+1
... I NUM="",DEN="" S BCT=BCT+1,NA=NA+1 Q
... I DEN'="",NUM="" S NO=NO+1 Q
... I DEN'="",NUM'="" S BCT=BCT+1,YES=YES+1
.. I NDA S NA=NA+1
.. I 'NO S PCT=PCT+1
.. Q
.. S PCT=$S(BCT=CNT:PCT+1,1:PCT)
. I '$G(WEEK) D STORP^BQIIPUTL(PRV,CODE,BQDATE,TP,PCT)
. I $G(WEEK)=1 D STORPW^BQIIPUTL(PRV,CODE,BQFROM,BQTHRU,TP,PCT)
. I $G(DEBUG)=1 W !,PRV,"|",CODE,"|",PCT,"/",TP
. S TDEN=TDEN+TP,TNUM=TNUM+PCT
S FAC=$$HME^BQIGPUTL()
I '$G(WEEK) D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
I $G(WEEK)=1 D STORFW^BQIIPUTL(FAC,CODE,BQFROM,BQTHRU,TDEN,TNUM)
I $G(DEBUG)=1 W !,FAC,"|",CODE,"|",TNUM,"/",TDEN
Q
;
BUN(CRSN,BNIEN,XX) ;EP - Get values for bundle
NEW BN,BCODE
S BN=0
F S BN=$O(^BQI(90508,1,22,CRSN,1,BNIEN,2,BN)) Q:'BN D
. S BCODE=$P(^BQI(90508,1,22,CRSN,1,BNIEN,2,BN,0),U,1)
. S XX(BCODE)=""
Q
;
PAT(DFN,XX) ;EP - See if patient meets bundle criteria
NEW BCT,PCT,CNT,CD,IEN,NUM,DEN,BQIDOD,NA,YES,NO,NDA
S BCT=0,PCT=0,CNT=0,NA=0,YES=0,NO=0,NDA=0
S BQIDOD=$$GET1^DIQ(2,DFN_",",.351,"I")
I BQIDOD'="" Q "{D}"
S CD="" F S CD=$O(XX(CD)) Q:CD="" S CNT=CNT+1
F S CD=$O(XX(CD)) Q:CD="" D
. I $P(CD,"_",1)="MU" S NA=NA+1 Q
. S IEN=$O(^BQIPAT(DFN,30,"B",CD,"")) I IEN="" S NDA=NDA+1 Q
. S NUM=$P(^BQIPAT(DFN,30,IEN,0),U,3)
. S DEN=$P(^BQIPAT(DFN,30,IEN,0),U,4)
. I NUM="",DEN="" S BCT=BCT+1,NA=NA+1 Q
. I DEN'="",NUM="" S NO=NO+1 Q
. I DEN'="",NUM'="" S BCT=BCT+1,YES=YES+1
I NDA Q "N/A"
I NA=CNT Q "N/A"
I YES=CNT Q "YES"
I 'NO Q "YES"
Q "NO"
;
PT(DFN,IPCN,CDN) ;EP
D BUN(IPCN,CDN,.XX)
S VAL=$$PAT(DFN,.XX)
Q VAL
BQIIPBNL ;VNGT/HS/ALA-IPC Bundle Logic ; 24 Jun 2011 11:53 AM
+1 ;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
+2 ;
+3 ;
EN(CRSN,BNIEN,BQDATE,CODE,BQFROM,BQTHRU) ;EP - do the bundle for monthly update
+1 ; Input
+2 ; CRSN - Current IPC IEN
+3 ; BNIEN - Bundle IEN
+4 ; CODE - Code name
+5 ; BQI(90508,1,22,CRN,1,MSN,1
+6 ;
+7 NEW TDEN,TNUM,CNT,CD,BQIDOD,NA,YES,NO,NDA
+8 SET BQDATE=$GET(BQDATE,"")
SET BQFROM=$GET(BQFROM,"")
SET BQTHRU=$GET(BQTHRU,"")
+9 SET TDEN=0
SET TNUM=0
SET CNT=0
+10 KILL XX
+11 DO BUN(CRSN,BNIEN,.XX)
+12 SET CD=""
FOR
SET CD=$ORDER(XX(CD))
IF CD=""
QUIT
SET CNT=CNT+1
+13 ;
+14 SET PRV=""
+15 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:1
+16 IF $PIECE(^VA(200,PRV,0),U,13)'=""
QUIT
+17 SET DFN=""
SET PCT=0
SET TP=0
+18 FOR
SET DFN=$ORDER(^AUPNPAT("AK",PRV,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+19 ;B:PRV=2911
+20 IF '$$HRN^BQIUL1(DFN)
QUIT
+21 SET VAL=$$PAT(DFN,.XX)
+22 IF VAL="N/A"!(VAL="{D}")
QUIT
+23 SET TP=TP+1
+24 IF VAL="YES"
SET PCT=PCT+1
+25 QUIT
+26 SET CD=""
SET BCT=0
SET NA=0
SET YES=0
SET NO=0
SET NDA=0
+27 FOR
SET CD=$ORDER(XX(CD))
IF CD=""
QUIT
Begin DoDot:3
+28 SET IEN=$ORDER(^BQIPAT(DFN,30,"B",CD,""))
IF IEN=""
SET NDA=NDA+1
QUIT
+29 SET BQIDOD=$$GET1^DIQ(2,DFN_",",.351,"I")
+30 IF BQIDOD'=""
QUIT
+31 SET NUM=$PIECE(^BQIPAT(DFN,30,IEN,0),U,3)
+32 SET DEN=$PIECE(^BQIPAT(DFN,30,IEN,0),U,4)
+33 SET TP=TP+1
+34 IF NUM=""
IF DEN=""
SET BCT=BCT+1
SET NA=NA+1
QUIT
+35 IF DEN'=""
IF NUM=""
SET NO=NO+1
QUIT
+36 IF DEN'=""
IF NUM'=""
SET BCT=BCT+1
SET YES=YES+1
End DoDot:3
+37 IF NDA
SET NA=NA+1
+38 IF 'NO
SET PCT=PCT+1
+39 QUIT
+40 SET PCT=$SELECT(BCT=CNT:PCT+1,1:PCT)
End DoDot:2
+41 IF '$GET(WEEK)
DO STORP^BQIIPUTL(PRV,CODE,BQDATE,TP,PCT)
+42 IF $GET(WEEK)=1
DO STORPW^BQIIPUTL(PRV,CODE,BQFROM,BQTHRU,TP,PCT)
+43 IF $GET(DEBUG)=1
WRITE !,PRV,"|",CODE,"|",PCT,"/",TP
+44 SET TDEN=TDEN+TP
SET TNUM=TNUM+PCT
End DoDot:1
+45 SET FAC=$$HME^BQIGPUTL()
+46 IF '$GET(WEEK)
DO STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
+47 IF $GET(WEEK)=1
DO STORFW^BQIIPUTL(FAC,CODE,BQFROM,BQTHRU,TDEN,TNUM)
+48 IF $GET(DEBUG)=1
WRITE !,FAC,"|",CODE,"|",TNUM,"/",TDEN
+49 QUIT
+50 ;
BUN(CRSN,BNIEN,XX) ;EP - Get values for bundle
+1 NEW BN,BCODE
+2 SET BN=0
+3 FOR
SET BN=$ORDER(^BQI(90508,1,22,CRSN,1,BNIEN,2,BN))
IF 'BN
QUIT
Begin DoDot:1
+4 SET BCODE=$PIECE(^BQI(90508,1,22,CRSN,1,BNIEN,2,BN,0),U,1)
+5 SET XX(BCODE)=""
End DoDot:1
+6 QUIT
+7 ;
PAT(DFN,XX) ;EP - See if patient meets bundle criteria
+1 NEW BCT,PCT,CNT,CD,IEN,NUM,DEN,BQIDOD,NA,YES,NO,NDA
+2 SET BCT=0
SET PCT=0
SET CNT=0
SET NA=0
SET YES=0
SET NO=0
SET NDA=0
+3 SET BQIDOD=$$GET1^DIQ(2,DFN_",",.351,"I")
+4 IF BQIDOD'=""
QUIT "{D}"
+5 SET CD=""
FOR
SET CD=$ORDER(XX(CD))
IF CD=""
QUIT
SET CNT=CNT+1
+6 FOR
SET CD=$ORDER(XX(CD))
IF CD=""
QUIT
Begin DoDot:1
+7 IF $PIECE(CD,"_",1)="MU"
SET NA=NA+1
QUIT
+8 SET IEN=$ORDER(^BQIPAT(DFN,30,"B",CD,""))
IF IEN=""
SET NDA=NDA+1
QUIT
+9 SET NUM=$PIECE(^BQIPAT(DFN,30,IEN,0),U,3)
+10 SET DEN=$PIECE(^BQIPAT(DFN,30,IEN,0),U,4)
+11 IF NUM=""
IF DEN=""
SET BCT=BCT+1
SET NA=NA+1
QUIT
+12 IF DEN'=""
IF NUM=""
SET NO=NO+1
QUIT
+13 IF DEN'=""
IF NUM'=""
SET BCT=BCT+1
SET YES=YES+1
End DoDot:1
+14 IF NDA
QUIT "N/A"
+15 IF NA=CNT
QUIT "N/A"
+16 IF YES=CNT
QUIT "YES"
+17 IF 'NO
QUIT "YES"
+18 QUIT "NO"
+19 ;
PT(DFN,IPCN,CDN) ;EP
+1 DO BUN(IPCN,CDN,.XX)
+2 SET VAL=$$PAT(DFN,.XX)
+3 QUIT VAL
