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

BQITDPRC.m

Go to the documentation of this file. 
  1. BQITDPRC ;PRXM/HC/ALA-Process Diagnosis Tag ; 11 May 2007  5:43 PM
  1.  ;;2.1;ICARE MANAGEMENT SYSTEM;**1**;Feb 07, 2011;Build 5
  1.  Q
  1.  ;
  1. EN(DATA,DFN,TAG,STAT,DATE,USR,SCOM,OCOM) ;EP -- BQI UPDATE DX CAT
  1.  ; Input
  1.  ;    DFN  - Patient internal entry number
  1.  ;    TAG  - the diagnosis tag internal entry number which is being updated
  1.  ;    STAT - status of the tag management
  1.  ;    DATE - Date of the update, assumes current date if not passed
  1.  ;           may be the date that the tag was last updated by nightly or
  1.  ;           weekly job
  1.  ;    USR  - User updating the tag, assumes DUZ if not passed
  1.  ;    SCOM - Standard comment value, should always be passed
  1.  ;    OCOM - Other comment value
  1.  ;
  1.  NEW UID,II,RDA,BI,TXT
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQITDPRC",UID))
  1.  K @DATA
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITDPRC D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S TAG=$G(TAG,"") I TAG="" S BMXSEC="No Diagnosis Category identified" Q
  1.  S STAT=$G(STAT,"") I STAT="" S BMXSEC="No status identified" Q
  1.  S DFN=$G(DFN,"") I DFN="" S BMXSEC="No patient identified" Q
  1.  S SCOM=$G(SCOM,"") I SCOM="" S BMXSEC="No standard comment value identified" Q
  1.  I $G(USR)="" S USR=$$GET1^DIQ(200,DUZ_",",.01,"E")
  1.  I $G(DATE)="" S DATE=$$NOW^XLFDT()
  1.  S OCOM=$G(OCOM,"")
  1.  ;
  1.  K BQTX
  1.  I $G(OCOM)[$C(10) D
  1.  . F BI=1:1 S TXT=$P(OCOM,$C(10),BI) Q:TXT=""  S BQTX(BI,0)=TXT
  1.  ;
  1.  I $G(OCOM)'[$C(10)&($G(OCOM)'="") S BQTX(1,0)=OCOM
  1.  ;
  1.  S @DATA@(II)="I00010RESULT^T00030MSG"_$C(30)
  1.  I TAG'?.N S TAG=$$FIND1^DIC(90506.2,"","",TAG,"B","","")
  1.  ;
  1.  ; if Asthma tag, check last severity value to determine if 'Accepted'
  1.  I TAG=1 D
  1.  . NEW SEV,TXN
  1.  . I STAT'="P" Q
  1.  . S SEV=$$LASTSEV^APCHSAST(DFN,1)
  1.  . I SEV<2 Q
  1.  . S STAT="A"
  1.  . S TXN=$O(BQTX(0))+1
  1.  . S BQTX(TXN,0)="Patient's severity was "_$$LASTSEV^APCHSAST(DFN,5)
  1.  ;
  1.  ;Build the BQIREG record and move the BQIPAT factors into BQIFACT
  1.  S RDA=$O(^BQIREG("C",DFN,TAG,""))
  1.  I RDA="" D NPAT(DFN,TAG,STAT,DATE,USR,SCOM,.BQTX) G DONE
  1.  ;
  1.  D UPAT(RDA,DFN,STAT,DATE,USR,SCOM,.BQTX)
  1.  ;
  1. DONE ;
  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)=$C(31)
  1.  Q
  1.  ;
  1. NPAT(BQIDFN,BQITAG,BQISTA,DATE,USR,SCOM,BQTX) ;EP - Create new patient record
  1.  NEW DIC,DLAYGO,DA,BQIUPD
  1.  K ERROR
  1.  S DIC(0)="L",DLAYGO=90509,X=BQITAG,DIC="^BQIREG("
  1.  K DO,DD D FILE^DICN
  1.  S DA=+Y
  1.  I DA=-1 S II=II+1,@DATA@(II)="-1^Unable to create record"_$C(30) Q
  1.  S BQIUPD(90509,DA_",",.02)=BQIDFN
  1.  S BQIUPD(90509,DA_",",.03)=BQISTA
  1.  S BQIUPD(90509,DA_",",.04)=DATE
  1.  S BQIUPD(90509,DA_",",.05)=USR
  1.  S BQIUPD(90509,DA_",",.06)=SCOM
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  I $D(BQTX)>0 D WP^DIE(90509,DA_",",1,"","BQTX","ERROR")
  1.  I $D(ERROR) S II=II+1,@DATA@(II)="-1"_"^"_$G(ERROR("DIERR",1,"TEXT",1))_$C(30) Q
  1.  I BQISTA="A" D MOV(BQIDFN,BQITAG)
  1.  ;
  1.  S BQIRDA=$O(^BQIREG("C",BQIDFN,BQITAG,""))
  1.  I BQIRDA D HIER
  1.  ;
  1.  S II=II+1,@DATA@(II)="1^"_$C(30)
  1.  Q
  1.  ;
  1. UPAT(BQIRDA,BQIDFN,BQISTA,DATE,USR,SCOM,BQTX) ;EP - Update patient record
  1.  NEW BQIUPD,ERROR,DIC,DA,PUSR,PSTAT,PCOM
  1.  ; Build history record
  1.  K FDA
  1.  ;S IENS="+1,"_BQIRDA_","
  1.  ;
  1.  S PSTAT=$P(^BQIREG(BQIRDA,0),U,3)
  1.  S PUSR=$P(^BQIREG(BQIRDA,0),U,5)
  1.  S PCOM=$P(^BQIREG(BQIRDA,0),U,6)
  1.  ;
  1.  S DIC(0)="L",DA(1)=BQIRDA,DIC="^BQIREG("_DA(1)_",10,",DIE=DIC
  1.  I $G(^BQIREG(DA(1),10,0))="" S ^BQIREG(DA(1),10,0)="^90509.01D^^"
  1.  S X=$$NOW^XLFDT()
  1.  K DO,DD D FILE^DICN S DA=+Y I DA=-1 Q
  1.  ;
  1.  S IENS=$$IENS^DILF(.DA)
  1.  S FDA(90509.01,IENS,.02)=PSTAT
  1.  S FDA(90509.01,IENS,.03)=PUSR
  1.  S FDA(90509.01,IENS,.04)=PCOM
  1.  S FDA(90509.01,IENS,.05)=$P(^BQIREG(BQIRDA,0),U,4)
  1.  D FILE^DIE("","FDA","ERROR")
  1.  ; Move comments
  1.  D WP^DIE(90509.01,IENS,1,"","^BQIREG(BQIRDA,1)")
  1.  ; Move factors
  1.  S NDA=0
  1.  F  S NDA=$O(^BQIREG(DA(1),5,NDA)) Q:'NDA  D
  1.  . S ^BQIREG(DA(1),10,DA,5,NDA,0)=^BQIREG(DA(1),5,NDA,0)
  1.  . S ^BQIREG(DA(1),10,DA,5,"B",NDA,NDA)=""
  1.  . K ^BQIREG(DA(1),5,NDA)
  1.  I $G(^BQIREG(DA(1),5,0))'="" S ^BQIREG(DA(1),10,DA,5,0)=$G(^BQIREG(DA(1),5,0))
  1.  K ^BQIREG(DA(1),5)
  1.  ;
  1.  I PSTAT="P" D MOV(BQIDFN,TAG)
  1.  ;
  1.  ; Set the new current values
  1.  S BQIUPD(90509,BQIRDA_",",.03)=BQISTA
  1.  S BQIUPD(90509,BQIRDA_",",.04)=DATE
  1.  S BQIUPD(90509,BQIRDA_",",.05)=USR
  1.  S BQIUPD(90509,BQIRDA_",",.06)=SCOM
  1.  S BQIUPD(90509,BQIRDA_",",1)="@"
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  K ERROR
  1.  ;
  1.  I $D(BQTX)>0 D WP^DIE(90509,BQIRDA_",",1,"","BQTX","ERROR")
  1.  ;
  1.  D HIER
  1.  ;
  1.  I $D(ERROR) S II=II+1,@DATA@(II)="-1^"_$C(30)
  1.  E  S II=II+1,@DATA@(II)="1^"_$C(30)
  1.  Q
  1.  ;
  1. MOV(BQIDFN,BQITAG) ;EP - Move factors
  1.  NEW BQIFN,BQIFAC,BQIDID,BQIRN,BQIREC,BQIRDT,BQIREX,BQIIEN,ADD
  1.  NEW BQIFIL,BQIVPR,BQII,SUBREG,STFILE,STFLD,RGDATA,GLBNOD,BQIASRG
  1.  I $G(^BQIPAT(BQIDFN,20,BQITAG,0))="" Q
  1.  S BQIDID=$P(^BQIPAT(BQIDFN,20,BQITAG,0),U,2)
  1.  S BQIFN=0
  1.  F  S BQIFN=$O(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN)) Q:'BQIFN  D
  1.  . S BQIFAC=$P($G(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,0)),U,1)
  1.  . I BQIFAC="" K ^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN) Q
  1.  . I BQIFAC["Age:" S BQIVPR="~" D CHKR Q
  1.  . S BQIRN=0
  1.  . F  S BQIRN=$O(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN)) Q:'BQIRN  D
  1.  .. S BQIREC=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,1)
  1.  .. S BQIRDT=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,2)
  1.  .. S BQIREX=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,3)
  1.  .. S BQIIEN=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,4)
  1.  .. S BQIFIL=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,5)
  1.  .. I $E(BQIREC,1,1)="P" S BQIVPR=$E(BQIREC,2,$L(BQIREC))_";AUPNPROB("
  1.  .. I $E(BQIREC,1,1)="V" S BQIVPR=$E(BQIREC,2,$L(BQIREC))_";AUPNVSIT("
  1.  .. I BQIREC="" Q
  1.  .. D CHKR
  1.  .. Q
  1.  . I BQIFAC[" Tag" D CHKR
  1.  ;
  1. DEL ;Delete proposed tag data from BQIPAT
  1.  NEW DA,DIK
  1.  S DA(1)=BQIDFN,DA=BQITAG,DIK="^BQIPAT("_DA(1)_",20,"
  1.  D ^DIK
  1.  Q
  1.  ;
  1. NREC ;EP - Create new factor record
  1.  NEW DIC,DLAYGO,X,DA,BQIUPD,ERROR
  1.  I $G(DATE)="" S DATE=DT
  1.  S DIC(0)="L",DLAYGO=90509.5,X=BQIFAC,DIC="^BQIFACT("
  1.  K DO,DD D FILE^DICN
  1.  S (DA,RDA)=+Y
  1.  S BQIUPD(90509.5,DA_",",.02)=BQIDFN
  1.  S BQIUPD(90509.5,DA_",",.03)=BQITAG
  1.  S BQIUPD(90509.5,DA_",",.04)=DATE
  1.  S BQIUPD(90509.5,DA_",",.05)=$G(BQIVPR)
  1.  S BQIUPD(90509.5,DA_",",.06)=$G(BQIRDT)
  1.  S BQIUPD(90509.5,DA_",",.07)=$G(BQIIEN)
  1.  S BQIUPD(90509.5,DA_",",.08)=$G(BQIFIL)
  1.  S BQIUPD(90509.5,DA_",",.09)=$G(BQIREX)
  1.  S BQIUPD(90509.5,DA_",",.1)=BQIDID
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  ;
  1. CF ; Set the factor into the CURRENT FACTORS multiple in ^BQIREG
  1.  NEW RIEN,DIC,DLAYGO,X,DA
  1.  S RIEN=$O(^BQIREG("C",BQIDFN,BQITAG,""))
  1.  I $G(^BQIREG(RIEN,5,0))="" S ^BQIREG(RIEN,5,0)="^90509.05P^^"
  1.  S DA(1)=RIEN
  1.  S DIC(0)="L",DLAYGO=90509.05,(X,DINUM)=RDA,DIC="^BQIREG("_DA(1)_",5,"
  1.  K DO,DD D FILE^DICN
  1.  Q
  1.  ;
  1. CHKR ;EP - Check for record
  1.  NEW BQIIFACT,BQIISR,BQIIFAC,BQIITG,BQIIVPR
  1.  S BQII=""
  1.  I $O(^BQIFACT("C",BQIDFN,BQITAG,BQII))="" D NREC Q
  1.  F  S BQII=$O(^BQIFACT("C",BQIDFN,BQITAG,BQII)) Q:BQII=""  D
  1.  . S BQIIFACT=^BQIFACT(BQII,0)
  1.  . S BQIIFAC=$P(BQIIFACT,U,1)
  1.  . S BQIITG=$P(BQIIFACT,U,3) S:BQIITG="" BQIITG="~"
  1.  . S BQIIVPR=$P(BQIIFACT,U,5) S:BQIIVPR="" BQIIVPR="~"
  1.  . S BQIISR(BQIIFAC,BQIITG,BQIIVPR)=""
  1.  ;
  1.  I '$D(BQIISR(BQIFAC,BQITAG)) D NREC Q
  1.  I '$D(BQIISR(BQIFAC,BQITAG,BQIVPR)) D NREC
  1.  Q
  1.  ;
  1. HIER ; Check for hierarchy and if BQISTA="N", set the next lower one
  1.  NEW TAG,THCFL,OK,NSTAT,HTAG,HSN,FCN,HIEN
  1.  S TAG=$P(^BQIREG(BQIRDA,0),U,1)
  1.  S THCFL=+$P(^BQI(90506.2,TAG,0),U,10)
  1.  I THCFL D
  1.  . I BQISTA="N" D
  1.  .. S OK=$$LOW^BQITDUTL(BQIDFN,TAG)
  1.  .. I 'OK Q
  1.  .. S HTAG=$P(OK,U,2)
  1.  .. S NSTAT=$S(HTAG=9:"A",1:"P")
  1.  .. D EN(.RDATA,BQIDFN,HTAG,NSTAT,,"REACTIVATED TAG",5)
  1.  .. ; Find the previous factors and move them back out of history
  1.  .. S HSN="A",QFL=0,HIEN=$O(^BQIREG("C",BQIDFN,HTAG,""))
  1.  .. F  S HSN=$O(^BQIREG(HIEN,10,HSN),-1) Q:'HSN  D  Q:QFL
  1.  ... S FCN=0
  1.  ... F  S FCN=$O(^BQIREG(HIEN,10,HSN,5,FCN)) Q:'FCN  D
  1.  .... S ^BQIREG(HIEN,5,FCN,0)=^BQIREG(HIEN,10,HSN,5,FCN,0)
  1.  .... S ^BQIREG(HIEN,5,"B",FCN,FCN)="",QFL=1
  1.  ... I QFL S ^BQIREG(HIEN,5,0)=^BQIREG(HIEN,10,HSN,5,0)
  1.  . ; If new active status, check for others in the hierarchy
  1.  . I BQISTA="A"!(BQISTA="P") D
  1.  .. S HSN="A",QFL=0
  1.  .. F  S HSN=$O(^BQIREG(BQIRDA,10,HSN),-1) Q:'HSN  D  Q:QFL
  1.  ... S FCN=0
  1.  ... F  S FCN=$O(^BQIREG(BQIRDA,10,HSN,5,FCN)) Q:'FCN  D
  1.  .... S ^BQIREG(BQIRDA,5,FCN,0)=^BQIREG(BQIRDA,10,HSN,5,FCN,0)
  1.  .... S ^BQIREG(BQIRDA,5,"B",FCN,FCN)="",QFL=1
  1.  ... I QFL S ^BQIREG(BQIRDA,5,0)=^BQIREG(BQIRDA,10,HSN,5,0)
  1.  .. ; if active lower, make it inactive with superseded
  1.  .. S OK=$$LOW^BQITDUTL(BQIDFN,TAG)
  1.  .. I OK S HTAG=$P(OK,U,2) D
  1.  ... I '$P(OK,U,3) Q
  1.  ... D EN(.RDATA,BQIDFN,HTAG,"S",,"SUPERSEDED",4)
  1.  Q