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

BQI2POS1.m

Go to the documentation of this file. 
  1. BQI2POS1 ;VNGT/HC/ALA - Continuation of Version 2.0 Post Install ; 25 Jul 2008  4:02 PM
  1.  ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
  1.  ;
  1. REG ;EP - Process Tags
  1.  ; First delete all tag data
  1.  NEW DFN,TAG,DA,DIK
  1.  S DFN=0
  1.  F  S DFN=$O(^BQIPAT(DFN)) Q:'DFN  D
  1.  . S TAG=0
  1.  . F  S TAG=$O(^BQIPAT(DFN,20,TAG)) Q:'TAG  D
  1.  .. S DA(1)=DFN,DA=TAG,DIK="^BQIPAT("_DA(1)_",20,"
  1.  .. D ^DIK
  1.  ;
  1.  ; Recalculate all tags
  1.  D DXC^BQITASK2
  1.  ;
  1. NX ; Process register records into tags
  1.  NEW REGIEN,RDATA,TAG,FILE,FIELD,XREF,STFILE,STFLD,STEX,SUBREG,GLBREF,GLBNOD
  1.  NEW DFN,RIEN,QFL,DATE,TGNM,CSTAT,PCAT,PSTAT
  1.  S REGIEN=0
  1.  F  S REGIEN=$O(^BQI(90507,REGIEN)) Q:'REGIEN  D
  1.  . S RDATA=^BQI(90507,REGIEN,0)
  1.  . ; If the register is inactive, quit
  1.  . I $P(RDATA,U,8)=1 Q
  1.  . ; Check if register is associated with a tag, if there isn't one, quit
  1.  . S TAG=$O(^BQI(90506.2,"AD",REGIEN,"")) I TAG="" Q
  1.  . S FILE=$P(RDATA,U,7),FIELD=$P(RDATA,U,5),XREF=$P(RDATA,U,6)
  1.  . S STFILE=$P(RDATA,U,15),STFLD=$P(RDATA,U,14),STEX=$G(^BQI(90507,REGIEN,1))
  1.  . S SUBREG=$P(RDATA,U,9)
  1.  . S GLBREF=$$ROOT^DILFD(FILE,"")_XREF_")"
  1.  . S GLBNOD=$$ROOT^DILFD(FILE,"",1)
  1.  . I GLBNOD="" Q
  1.  . ;
  1.  . I '$D(@GLBNOD@(0)) Q
  1.  . ;
  1.  . S DFN=""
  1.  . F  S DFN=$O(@GLBREF@(DFN)) Q:DFN=""  D
  1.  .. ; If patient is deceased, quit
  1.  .. I $P($G(^DPT(DFN,.35)),U,1)'="" Q
  1.  .. ; If patient has no active HRNs, quit
  1.  .. I '$$HRN^BQIUL1(DFN),'$$VTHR^BQIUL1(DFN) Q
  1.  .. ;
  1.  .. I $G(SUBREG)'="" S QFL=0 D  Q:'QFL
  1.  ... Q:FILE'=9002241
  1.  ... S RIEN=""
  1.  ... F  S RIEN=$O(@GLBREF@(DFN,RIEN)) Q:RIEN=""  D
  1.  .... I $P($G(@GLBNOD@(RIEN,0)),U,5)=SUBREG S QFL=1,IENS=RIEN
  1.  .. ; Check register status
  1.  .. I $G(SUBREG)="" S IENS=$O(@GLBREF@(DFN,""))
  1.  .. I STEX'="" X STEX Q:'$D(IENS)
  1.  .. S PSTAT=$$GET1^DIQ(STFILE,IENS,STFLD,"I"),CSTAT="",PCAT=""
  1.  .. I STFILE=90451.01 S PCAT=$$GET1^DIQ(STFILE,IENS,2.3,"I")
  1.  .. I $O(^BQIREG("C",DFN,TAG,""))'="" S CSTAT=$$ATAG^BQITDUTL(DFN,TAG)
  1.  .. I $P(CSTAT,U,2)="A" Q
  1.  .. S DATE=$P($G(^BQIPAT(DFN,20,TAG,0)),U,2)
  1.  .. I $O(^BQIREG("C",DFN,TAG,""))'="" Q
  1.  .. I PSTAT="U"!(PSTAT="")!(PSTAT="I") D  Q
  1.  ... ; If patient is not tagged, quit
  1.  ... I $O(^BQIPAT(DFN,20,TAG,0))="" Q
  1.  ... I $O(^BQIREG("C",DFN,TAG,""))'="" Q
  1.  ... I TAG=3&($E(PCAT,1)="E")!(PCAT="") Q
  1.  ... ; else build a "proposed" record
  1.  ... D EN^BQITDPRC(.DATA,DFN,TAG,"P",DATE,"POST INSTALL JOB",8,"Register status is "_PSTAT) Q
  1.  .. I $O(^BQIPAT(DFN,20,TAG,0))'="" D
  1.  ... I PCAT="H"!(PCAT="A") D EN^BQITDPRC(.DATA,DFN,TAG,"A",DATE,"POST INSTALL JOB",8,"Register status is "_PSTAT) Q
  1.  ... D EN^BQITDPRC(.DATA,DFN,TAG,"P",DATE,"POST INSTALL JOB",8,"Register status is "_PSTAT)
  1.  .. I $O(^BQIPAT(DFN,20,TAG,0))="" D
  1.  ... I TAG=3&($E(PCAT,1)="E")!(PCAT="") Q
  1.  ... D EN^BQITDPRC(.DATA,DFN,TAG,"P",DATE,"POST INSTALL JOB",8,"Register status is "_PSTAT)
  1.  .. ; Remove any temporary BQIPAT data
  1.  .. NEW DA,DIK
  1.  .. S DA(1)=DFN,DA=TAG,DIK="^BQIPAT("_DA(1)_",20,"
  1.  .. D ^DIK
  1.  ;
  1. TG ; Set up Proposed records in BQIREG
  1.  S DFN=0
  1.  F  S DFN=$O(^BQIPAT(DFN)) Q:'DFN  D
  1.  . S TAG=0
  1.  . F  S TAG=$O(^BQIPAT(DFN,20,TAG)) Q:'TAG  D
  1.  .. ; If there is already a record, quit
  1.  .. I $O(^BQIREG("C",DFN,TAG,""))'="" Q
  1.  .. ; Get date that the tag was last identified
  1.  .. S DATE=$P(^BQIPAT(DFN,20,TAG,0),"^",2)
  1.  .. ; Get the tag name
  1.  .. S TGNM=$P(^BQI(90506.2,TAG,0),"^",1)
  1.  .. ; If the tag is CVD At Risk, then it automatically becomes 'Accepted'
  1.  .. I TGNM="CVD At Risk" D  Q
  1.  ... D EN^BQITDPRC(.DATA,DFN,TAG,"A",DATE,"POST INSTALL JOB",5)
  1.  ... NEW DA,DIK
  1.  ... S DA(1)=DFN,DA=TAG,DIK="^BQIPAT("_DA(1)_",20,"
  1.  ... D ^DIK
  1.  .. ; Otherwise, it is a 'Proposed' tag
  1.  .. D EN^BQITDPRC(.DATA,DFN,TAG,"P",DATE,"POST INSTALL JOB",5)
  1.  ;
  1. CN ;Check HMS Candidate file
  1.  NEW STAT,BQDA,TAG
  1.  S BQDA=0,TAG=3
  1.  F  S BQDA=$O(^BKM(90451.2,BQDA)) Q:'BQDA  D
  1.  . S BQDFN=$P(^BKM(90451.2,BQDA,0),U,1),STAT=$P(^(0),U,3)
  1.  . ; if the status is not NOT:NOT ACCEPTED or REM:REMOVED, quit
  1.  . I STAT'="NOT"&(STAT'="REM") D  Q
  1.  .. I $O(^BQIREG("C",BQDFN,TAG,""))'="" Q
  1.  .. D EN^BQITDPRC(.DATA,BQDFN,TAG,"P",DATE,"POST INSTALL JOB",1,"Patient originally on HMS Candidate List")
  1.  . S DATE=$S($P(^BKM(90451.2,BQDA,0),U,5)'="":$P(^(0),U,5),1:"")
  1.  . S USER=$S($P(^BKM(90451.2,BQDA,0),U,6)'="":$P(^VA(200,$P(^(0),U,6),0),U,1),1:"POST INSTALL JOB")
  1.  . ; If the recalculate of tags created a record, delete it
  1.  . I $O(^BQIREG("C",BQDFN,TAG,""))'="" D
  1.  .. NEW DIK,DA
  1.  .. S DIK="^BQIREG(",DA=$O(^BQIREG("C",BQDFN,TAG,"")) D ^DIK
  1.  .. S DA(1)=BQDFN,DA=TAG,DIK="^BQIPAT("_DA(1)_",20," D ^DIK
  1.  . D EN^BQITDPRC(.DATA,BQDFN,TAG,"N",DATE,USER,1,"Patient on HMS Register has status Not Accepted or Removed.")
  1.  ;
  1.  ; Check if any HIV record is 'No Longer Valid' and reset comment
  1.  NEW RIEN
  1.  S RIEN=""
  1.  F  S RIEN=$O(^BQIREG("B",3,RIEN)) Q:RIEN=""  D
  1.  . S STAT=$P(^BQIREG(RIEN,0),U,3)
  1.  . I STAT'="V" Q
  1.  . S BQIUPD(90509,RIEN_",",.06)=9
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  ;
  1. AS ; Set any Asthma's (IEN=1) to accepted if the severity value is 2,3, or 4
  1.  S RIEN=""
  1.  F  S RIEN=$O(^BQIREG("B",1,RIEN)) Q:RIEN=""  D
  1.  . S STAT=$P(^BQIREG(RIEN,0),U,3),DFN=$P(^(0),U,2)
  1.  . I '$$ACST^BQITDUTL(STAT) Q
  1.  . S SEV=$$LASTSEV^APCHSAST(DFN,1)
  1.  . I SEV<2 Q
  1.  . K BQTX
  1.  . S BQIUPD(90509,RIEN_",",.03)="A"
  1.  . S BQIUPD(90509,RIEN_",",.06)=9
  1.  . D FILE^DIE("I","BQIUPD","ERROR")
  1.  . S BQTX(1,0)="Patient's severity was "_$$LASTSEV^APCHSAST(DFN,5)
  1.  . D WP^DIE(90509,RIEN_",",1,"","BQTX","ERROR")
  1.  . K BQIUPD
  1.  ;
  1.  ; Set up treatment prompts
  1.  D EN^BQITASK3
  1.  Q