- 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
