Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQITDPAT

BQITDPAT.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  Q
  1.  ;
  1. PAT(DATA,DFN) ;EP -- BQI POPULATE DX CAT BY PATIENT
  1.  ;Description
  1.  ;  Recalculate diagnosis categories for a single patient
  1.  ;Input
  1.  ;  DFN - Patient internal entry number
  1.  ;Parameters
  1.  ;  BQORD  - Diagnosis order number
  1.  ;  BQTN   - Diagnosis category IEN
  1.  ;  BQDEF  - Diagnosis category name
  1.  ;  BQEXEC - If special executable code is need for dx cat
  1.  ;  BQPRG  - Dx Cat program
  1.  ;  BQTGLB  - Temporary global reference
  1.  ;  VOK    - If 0 (zero) then patient isn't valid for this dx cat,
  1.  ;           if 1 (one) then patient does meet criteria for this dx cat
  1.  NEW UID,II,X
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQITDPAT",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITDPAT D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S @DATA@(II)="I00010RESULT"_$C(30)
  1.  ;
  1.  NEW BQTN,BQDEF,BQORD,BQEXEC,BQPRG,BQTGLB,PRGM
  1.  S BQORD=""
  1.  F  S BQORD=$O(^BQI(90506.2,"AC",BQORD)) Q:BQORD=""  D
  1.  . S BQTN=""
  1.  . F  S BQTN=$O(^BQI(90506.2,"AC",BQORD,BQTN)) Q:BQTN=""  D
  1.  .. ; If the category is marked as inactive, ignore it
  1.  .. I $$GET1^DIQ(90506.2,BQTN_",",.03,"I") Q
  1.  .. ; If the category is a subdefinition, ignore it
  1.  .. I $$GET1^DIQ(90506.2,BQTN_",",.05,"I")=1 Q
  1.  .. S BQDEF=$$GET1^DIQ(90506.2,BQTN_",",.01,"E")
  1.  .. S BQEXEC=$$GET1^DIQ(90506.2,BQTN_",",1,"E")
  1.  .. S BQPRG=$$GET1^DIQ(90506.2,BQTN_",",.04,"E")
  1.  .. ;
  1.  .. S BQTGLB=$NA(^TMP("BQIPDXC",UID))
  1.  .. K @BQTGLB
  1.  .. ;
  1.  .. ; Call the individual patient dx category code
  1.  .. S PRGM="S VOK=""$$PAT^""_BQPRG_""(BQDEF,.BQTGLB,DFN)"""
  1.  .. X PRGM
  1.  .. ;
  1.  .. ; File the returned data
  1.  .. D CHK(BQTGLB,DFN)
  1.  .. K @BQTGLB
  1.  .. K TAX,VSDT,TIEN,TDXN,PLFLG,N,BQIRY,BQITRY,ARRAY,BCLN,BMI,BGDT,BQDREF,BQDXN,BQGLB
  1.  .. K BDATE,EDATE,FLAG,GREF,FREF,PLFLG,BQGLB1,BQGLBT,BQIREF,BTYP,CIRCUM,CRDATA,DATE
  1.  .. K ENDT,EXDT,GFDATA,IEN,IENS,MFL,MIENS,PROB,QFL,RESULT,RESULTS,STDT,TMDATA,TMGLB2
  1.  .. K TMREF,TPRGL,TREF,TYP,VSDTM
  1.  .. Q
  1.  ;
  1.  S BQIUPD(90507.5,DFN_",",.06)=$$NOW^XLFDT()
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  K BQIUPD
  1.  I $G(BQTGLB)'="" K @BQTGLB,BQTGLB
  1.  K AGE,BQEXEC,BQDEF,BQPRG,DFN,PRGM,SEX,TXDXCN,TXDXCT,TXT,Y,X,VOK
  1.  S II=II+1,@DATA@(II)="1"_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)="-1"_$C(30)
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. CHK(BQTGLB,DFN) ; Check whether met criteria or not
  1.  ;
  1.  ; Yes, met criteria
  1.  I @VOK D FIL^BQITASK(BQTGLB,DFN) Q
  1.  ; No, didn't meet criteria
  1.  D NCR^BQITDUTL(DFN,BQTN)
  1.  ; Remove previous criteria
  1.  NEW DA,DIK
  1.  S DA(2)=DFN,DA(1)=BQTN,DA=0,DIK="^BQIPAT("_DA(2)_",20,"_DA(1)_",1,"
  1.  F  S DA=$O(^BQIPAT(DFN,20,BQTN,1,DA)) Q:'DA  D ^DIK
  1.  K ^BQIPAT(DFN,20,BQTN,1,"B")
  1.  Q
  1.  ;
  1. FIL(BQGLB,DFN) ;EP - File diagnosis category
  1.  Q