BQITDPAT ;PRXM/HC/ALA - Calculate DX Cat for single patient ; 26 Jul 2006 10:35 AM
;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
;
Q
;
PAT(DATA,DFN) ;EP -- BQI POPULATE DX CAT BY PATIENT
;Description
; Recalculate diagnosis categories for a single patient
;Input
; DFN - Patient internal entry number
;Parameters
; BQORD - Diagnosis order number
; BQTN - Diagnosis category IEN
; BQDEF - Diagnosis category name
; BQEXEC - If special executable code is need for dx cat
; BQPRG - Dx Cat program
; BQTGLB - Temporary global reference
; VOK - If 0 (zero) then patient isn't valid for this dx cat,
; if 1 (one) then patient does meet criteria for this dx cat
NEW UID,II,X
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQITDPAT",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITDPAT D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="I00010RESULT"_$C(30)
;
NEW BQTN,BQDEF,BQORD,BQEXEC,BQPRG,BQTGLB,PRGM
S BQORD=""
F S BQORD=$O(^BQI(90506.2,"AC",BQORD)) Q:BQORD="" D
. S BQTN=""
. F S BQTN=$O(^BQI(90506.2,"AC",BQORD,BQTN)) Q:BQTN="" D
.. ; If the category is marked as inactive, ignore it
.. I $$GET1^DIQ(90506.2,BQTN_",",.03,"I") Q
.. ; If the category is a subdefinition, ignore it
.. I $$GET1^DIQ(90506.2,BQTN_",",.05,"I")=1 Q
.. S BQDEF=$$GET1^DIQ(90506.2,BQTN_",",.01,"E")
.. S BQEXEC=$$GET1^DIQ(90506.2,BQTN_",",1,"E")
.. S BQPRG=$$GET1^DIQ(90506.2,BQTN_",",.04,"E")
.. ;
.. S BQTGLB=$NA(^TMP("BQIPDXC",UID))
.. K @BQTGLB
.. ;
.. ; Call the individual patient dx category code
.. S PRGM="S VOK=""$$PAT^""_BQPRG_""(BQDEF,.BQTGLB,DFN)"""
.. X PRGM
.. ;
.. ; File the returned data
.. D CHK(BQTGLB,DFN)
.. K @BQTGLB
.. K TAX,VSDT,TIEN,TDXN,PLFLG,N,BQIRY,BQITRY,ARRAY,BCLN,BMI,BGDT,BQDREF,BQDXN,BQGLB
.. K BDATE,EDATE,FLAG,GREF,FREF,PLFLG,BQGLB1,BQGLBT,BQIREF,BTYP,CIRCUM,CRDATA,DATE
.. K ENDT,EXDT,GFDATA,IEN,IENS,MFL,MIENS,PROB,QFL,RESULT,RESULTS,STDT,TMDATA,TMGLB2
.. K TMREF,TPRGL,TREF,TYP,VSDTM
.. Q
;
S BQIUPD(90507.5,DFN_",",.06)=$$NOW^XLFDT()
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
I $G(BQTGLB)'="" K @BQTGLB,BQTGLB
K AGE,BQEXEC,BQDEF,BQPRG,DFN,PRGM,SEX,TXDXCN,TXDXCT,TXT,Y,X,VOK
S II=II+1,@DATA@(II)="1"_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)="-1"_$C(30)
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
CHK(BQTGLB,DFN) ; Check whether met criteria or not
;
; Yes, met criteria
I @VOK D FIL^BQITASK(BQTGLB,DFN) Q
; No, didn't meet criteria
D NCR^BQITDUTL(DFN,BQTN)
; Remove previous criteria
NEW DA,DIK
S DA(2)=DFN,DA(1)=BQTN,DA=0,DIK="^BQIPAT("_DA(2)_",20,"_DA(1)_",1,"
F S DA=$O(^BQIPAT(DFN,20,BQTN,1,DA)) Q:'DA D ^DIK
K ^BQIPAT(DFN,20,BQTN,1,"B")
Q
;
FIL(BQGLB,DFN) ;EP - File diagnosis category
Q
BQITDPAT ;PRXM/HC/ALA - Calculate DX Cat for single patient ; 26 Jul 2006 10:35 AM
+1 ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
+2 ;
+3 QUIT
+4 ;
PAT(DATA,DFN) ;EP -- BQI POPULATE DX CAT BY PATIENT
+1 ;Description
+2 ; Recalculate diagnosis categories for a single patient
+3 ;Input
+4 ; DFN - Patient internal entry number
+5 ;Parameters
+6 ; BQORD - Diagnosis order number
+7 ; BQTN - Diagnosis category IEN
+8 ; BQDEF - Diagnosis category name
+9 ; BQEXEC - If special executable code is need for dx cat
+10 ; BQPRG - Dx Cat program
+11 ; BQTGLB - Temporary global reference
+12 ; VOK - If 0 (zero) then patient isn't valid for this dx cat,
+13 ; if 1 (one) then patient does meet criteria for this dx cat
+14 NEW UID,II,X
+15 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+16 SET DATA=$NAME(^TMP("BQITDPAT",UID))
+17 KILL @DATA
+18 ;
+19 SET II=0
+20 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQITDPAT D UNWIND^%ZTER"
+21 ;
+22 SET @DATA@(II)="I00010RESULT"_$CHAR(30)
+23 ;
+24 NEW BQTN,BQDEF,BQORD,BQEXEC,BQPRG,BQTGLB,PRGM
+25 SET BQORD=""
+26 FOR
SET BQORD=$ORDER(^BQI(90506.2,"AC",BQORD))
IF BQORD=""
QUIT
Begin DoDot:1
+27 SET BQTN=""
+28 FOR
SET BQTN=$ORDER(^BQI(90506.2,"AC",BQORD,BQTN))
IF BQTN=""
QUIT
Begin DoDot:2
+29 ; If the category is marked as inactive, ignore it
+30 IF $$GET1^DIQ(90506.2,BQTN_",",.03,"I")
QUIT
+31 ; If the category is a subdefinition, ignore it
+32 IF $$GET1^DIQ(90506.2,BQTN_",",.05,"I")=1
QUIT
+33 SET BQDEF=$$GET1^DIQ(90506.2,BQTN_",",.01,"E")
+34 SET BQEXEC=$$GET1^DIQ(90506.2,BQTN_",",1,"E")
+35 SET BQPRG=$$GET1^DIQ(90506.2,BQTN_",",.04,"E")
+36 ;
+37 SET BQTGLB=$NAME(^TMP("BQIPDXC",UID))
+38 KILL @BQTGLB
+39 ;
+40 ; Call the individual patient dx category code
+41 SET PRGM="S VOK=""$$PAT^""_BQPRG_""(BQDEF,.BQTGLB,DFN)"""
+42 XECUTE PRGM
+43 ;
+44 ; File the returned data
+45 DO CHK(BQTGLB,DFN)
+46 KILL @BQTGLB
+47 KILL TAX,VSDT,TIEN,TDXN,PLFLG,N,BQIRY,BQITRY,ARRAY,BCLN,BMI,BGDT,BQDREF,BQDXN,BQGLB
+48 KILL BDATE,EDATE,FLAG,GREF,FREF,PLFLG,BQGLB1,BQGLBT,BQIREF,BTYP,CIRCUM,CRDATA,DATE
+49 KILL ENDT,EXDT,GFDATA,IEN,IENS,MFL,MIENS,PROB,QFL,RESULT,RESULTS,STDT,TMDATA,TMGLB2
+50 KILL TMREF,TPRGL,TREF,TYP,VSDTM
+51 QUIT
End DoDot:2
End DoDot:1
+52 ;
+53 SET BQIUPD(90507.5,DFN_",",.06)=$$NOW^XLFDT()
+54 DO FILE^DIE("","BQIUPD","ERROR")
+55 KILL BQIUPD
+56 IF $GET(BQTGLB)'=""
KILL @BQTGLB,BQTGLB
+57 KILL AGE,BQEXEC,BQDEF,BQPRG,DFN,PRGM,SEX,TXDXCN,TXDXCT,TXT,Y,X,VOK
+58 SET II=II+1
SET @DATA@(II)="1"_$CHAR(30)
+59 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+60 QUIT
+61 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
+6 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+7 QUIT
+8 ;
CHK(BQTGLB,DFN) ; Check whether met criteria or not
+1 ;
+2 ; Yes, met criteria
+3 IF @VOK
DO FIL^BQITASK(BQTGLB,DFN)
QUIT
+4 ; No, didn't meet criteria
+5 DO NCR^BQITDUTL(DFN,BQTN)
+6 ; Remove previous criteria
+7 NEW DA,DIK
+8 SET DA(2)=DFN
SET DA(1)=BQTN
SET DA=0
SET DIK="^BQIPAT("_DA(2)_",20,"_DA(1)_",1,"
+9 FOR
SET DA=$ORDER(^BQIPAT(DFN,20,BQTN,1,DA))
IF 'DA
QUIT
DO ^DIK
+10 KILL ^BQIPAT(DFN,20,BQTN,1,"B")
+11 QUIT
+12 ;
FIL(BQGLB,DFN) ;EP - File diagnosis category
+1 QUIT
