BQI2POS1 ;VNGT/HC/ALA - Continuation of Version 2.0 Post Install ; 25 Jul 2008 4:02 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
REG ;EP - Process Tags
; First delete all tag data
NEW DFN,TAG,DA,DIK
S DFN=0
F S DFN=$O(^BQIPAT(DFN)) Q:'DFN D
. S TAG=0
. F S TAG=$O(^BQIPAT(DFN,20,TAG)) Q:'TAG D
.. S DA(1)=DFN,DA=TAG,DIK="^BQIPAT("_DA(1)_",20,"
.. D ^DIK
;
; Recalculate all tags
D DXC^BQITASK2
;
NX ; Process register records into tags
NEW REGIEN,RDATA,TAG,FILE,FIELD,XREF,STFILE,STFLD,STEX,SUBREG,GLBREF,GLBNOD
NEW DFN,RIEN,QFL,DATE,TGNM,CSTAT,PCAT,PSTAT
S REGIEN=0
F S REGIEN=$O(^BQI(90507,REGIEN)) Q:'REGIEN D
. S RDATA=^BQI(90507,REGIEN,0)
. ; If the register is inactive, quit
. I $P(RDATA,U,8)=1 Q
. ; Check if register is associated with a tag, if there isn't one, quit
. S TAG=$O(^BQI(90506.2,"AD",REGIEN,"")) I TAG="" Q
. S FILE=$P(RDATA,U,7),FIELD=$P(RDATA,U,5),XREF=$P(RDATA,U,6)
. S STFILE=$P(RDATA,U,15),STFLD=$P(RDATA,U,14),STEX=$G(^BQI(90507,REGIEN,1))
. S SUBREG=$P(RDATA,U,9)
. S GLBREF=$$ROOT^DILFD(FILE,"")_XREF_")"
. S GLBNOD=$$ROOT^DILFD(FILE,"",1)
. I GLBNOD="" Q
. ;
. I '$D(@GLBNOD@(0)) Q
. ;
. S DFN=""
. F S DFN=$O(@GLBREF@(DFN)) Q:DFN="" D
.. ; If patient is deceased, quit
.. I $P($G(^DPT(DFN,.35)),U,1)'="" Q
.. ; If patient has no active HRNs, quit
.. I '$$HRN^BQIUL1(DFN),'$$VTHR^BQIUL1(DFN) Q
.. ;
.. I $G(SUBREG)'="" S QFL=0 D Q:'QFL
... Q:FILE'=9002241
... S RIEN=""
... F S RIEN=$O(@GLBREF@(DFN,RIEN)) Q:RIEN="" D
.... I $P($G(@GLBNOD@(RIEN,0)),U,5)=SUBREG S QFL=1,IENS=RIEN
.. ; Check register status
.. I $G(SUBREG)="" S IENS=$O(@GLBREF@(DFN,""))
.. I STEX'="" X STEX Q:'$D(IENS)
.. S PSTAT=$$GET1^DIQ(STFILE,IENS,STFLD,"I"),CSTAT="",PCAT=""
.. I STFILE=90451.01 S PCAT=$$GET1^DIQ(STFILE,IENS,2.3,"I")
.. I $O(^BQIREG("C",DFN,TAG,""))'="" S CSTAT=$$ATAG^BQITDUTL(DFN,TAG)
.. I $P(CSTAT,U,2)="A" Q
.. S DATE=$P($G(^BQIPAT(DFN,20,TAG,0)),U,2)
.. I $O(^BQIREG("C",DFN,TAG,""))'="" Q
.. I PSTAT="U"!(PSTAT="")!(PSTAT="I") D Q
... ; If patient is not tagged, quit
... I $O(^BQIPAT(DFN,20,TAG,0))="" Q
... I $O(^BQIREG("C",DFN,TAG,""))'="" Q
... I TAG=3&($E(PCAT,1)="E")!(PCAT="") Q
... ; else build a "proposed" record
... D EN^BQITDPRC(.DATA,DFN,TAG,"P",DATE,"POST INSTALL JOB",8,"Register status is "_PSTAT) Q
.. I $O(^BQIPAT(DFN,20,TAG,0))'="" D
... I PCAT="H"!(PCAT="A") D EN^BQITDPRC(.DATA,DFN,TAG,"A",DATE,"POST INSTALL JOB",8,"Register status is "_PSTAT) Q
... D EN^BQITDPRC(.DATA,DFN,TAG,"P",DATE,"POST INSTALL JOB",8,"Register status is "_PSTAT)
.. I $O(^BQIPAT(DFN,20,TAG,0))="" D
... I TAG=3&($E(PCAT,1)="E")!(PCAT="") Q
... D EN^BQITDPRC(.DATA,DFN,TAG,"P",DATE,"POST INSTALL JOB",8,"Register status is "_PSTAT)
.. ; Remove any temporary BQIPAT data
.. NEW DA,DIK
.. S DA(1)=DFN,DA=TAG,DIK="^BQIPAT("_DA(1)_",20,"
.. D ^DIK
;
TG ; Set up Proposed records in BQIREG
S DFN=0
F S DFN=$O(^BQIPAT(DFN)) Q:'DFN D
. S TAG=0
. F S TAG=$O(^BQIPAT(DFN,20,TAG)) Q:'TAG D
.. ; If there is already a record, quit
.. I $O(^BQIREG("C",DFN,TAG,""))'="" Q
.. ; Get date that the tag was last identified
.. S DATE=$P(^BQIPAT(DFN,20,TAG,0),"^",2)
.. ; Get the tag name
.. S TGNM=$P(^BQI(90506.2,TAG,0),"^",1)
.. ; If the tag is CVD At Risk, then it automatically becomes 'Accepted'
.. I TGNM="CVD At Risk" D Q
... D EN^BQITDPRC(.DATA,DFN,TAG,"A",DATE,"POST INSTALL JOB",5)
... NEW DA,DIK
... S DA(1)=DFN,DA=TAG,DIK="^BQIPAT("_DA(1)_",20,"
... D ^DIK
.. ; Otherwise, it is a 'Proposed' tag
.. D EN^BQITDPRC(.DATA,DFN,TAG,"P",DATE,"POST INSTALL JOB",5)
;
CN ;Check HMS Candidate file
NEW STAT,BQDA,TAG
S BQDA=0,TAG=3
F S BQDA=$O(^BKM(90451.2,BQDA)) Q:'BQDA D
. S BQDFN=$P(^BKM(90451.2,BQDA,0),U,1),STAT=$P(^(0),U,3)
. ; if the status is not NOT:NOT ACCEPTED or REM:REMOVED, quit
. I STAT'="NOT"&(STAT'="REM") D Q
.. I $O(^BQIREG("C",BQDFN,TAG,""))'="" Q
.. D EN^BQITDPRC(.DATA,BQDFN,TAG,"P",DATE,"POST INSTALL JOB",1,"Patient originally on HMS Candidate List")
. S DATE=$S($P(^BKM(90451.2,BQDA,0),U,5)'="":$P(^(0),U,5),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")
. ; If the recalculate of tags created a record, delete it
. I $O(^BQIREG("C",BQDFN,TAG,""))'="" D
.. NEW DIK,DA
.. S DIK="^BQIREG(",DA=$O(^BQIREG("C",BQDFN,TAG,"")) D ^DIK
.. S DA(1)=BQDFN,DA=TAG,DIK="^BQIPAT("_DA(1)_",20," D ^DIK
. D EN^BQITDPRC(.DATA,BQDFN,TAG,"N",DATE,USER,1,"Patient on HMS Register has status Not Accepted or Removed.")
;
; Check if any HIV record is 'No Longer Valid' and reset comment
NEW RIEN
S RIEN=""
F S RIEN=$O(^BQIREG("B",3,RIEN)) Q:RIEN="" D
. S STAT=$P(^BQIREG(RIEN,0),U,3)
. I STAT'="V" Q
. S BQIUPD(90509,RIEN_",",.06)=9
D FILE^DIE("","BQIUPD","ERROR")
;
AS ; Set any Asthma's (IEN=1) to accepted if the severity value is 2,3, or 4
S RIEN=""
F S RIEN=$O(^BQIREG("B",1,RIEN)) Q:RIEN="" D
. S STAT=$P(^BQIREG(RIEN,0),U,3),DFN=$P(^(0),U,2)
. I '$$ACST^BQITDUTL(STAT) Q
. S SEV=$$LASTSEV^APCHSAST(DFN,1)
. I SEV<2 Q
. K BQTX
. S BQIUPD(90509,RIEN_",",.03)="A"
. S BQIUPD(90509,RIEN_",",.06)=9
. D FILE^DIE("I","BQIUPD","ERROR")
. S BQTX(1,0)="Patient's severity was "_$$LASTSEV^APCHSAST(DFN,5)
. D WP^DIE(90509,RIEN_",",1,"","BQTX","ERROR")
. K BQIUPD
;
; Set up treatment prompts
D EN^BQITASK3
Q
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
+2 ;
REG ;EP - Process Tags
+1 ; First delete all tag data
+2 NEW DFN,TAG,DA,DIK
+3 SET DFN=0
+4 FOR
SET DFN=$ORDER(^BQIPAT(DFN))
IF 'DFN
QUIT
Begin DoDot:1
+5 SET TAG=0
+6 FOR
SET TAG=$ORDER(^BQIPAT(DFN,20,TAG))
IF 'TAG
QUIT
Begin DoDot:2
+7 SET DA(1)=DFN
SET DA=TAG
SET DIK="^BQIPAT("_DA(1)_",20,"
+8 DO ^DIK
End DoDot:2
End DoDot:1
+9 ;
+10 ; Recalculate all tags
+11 DO DXC^BQITASK2
+12 ;
NX ; Process register records into tags
+1 NEW REGIEN,RDATA,TAG,FILE,FIELD,XREF,STFILE,STFLD,STEX,SUBREG,GLBREF,GLBNOD
+2 NEW DFN,RIEN,QFL,DATE,TGNM,CSTAT,PCAT,PSTAT
+3 SET REGIEN=0
+4 FOR
SET REGIEN=$ORDER(^BQI(90507,REGIEN))
IF 'REGIEN
QUIT
Begin DoDot:1
+5 SET RDATA=^BQI(90507,REGIEN,0)
+6 ; If the register is inactive, quit
+7 IF $PIECE(RDATA,U,8)=1
QUIT
+8 ; Check if register is associated with a tag, if there isn't one, quit
+9 SET TAG=$ORDER(^BQI(90506.2,"AD",REGIEN,""))
IF TAG=""
QUIT
+10 SET FILE=$PIECE(RDATA,U,7)
SET FIELD=$PIECE(RDATA,U,5)
SET XREF=$PIECE(RDATA,U,6)
+11 SET STFILE=$PIECE(RDATA,U,15)
SET STFLD=$PIECE(RDATA,U,14)
SET STEX=$GET(^BQI(90507,REGIEN,1))
+12 SET SUBREG=$PIECE(RDATA,U,9)
+13 SET GLBREF=$$ROOT^DILFD(FILE,"")_XREF_")"
+14 SET GLBNOD=$$ROOT^DILFD(FILE,"",1)
+15 IF GLBNOD=""
QUIT
+16 ;
+17 IF '$DATA(@GLBNOD@(0))
QUIT
+18 ;
+19 SET DFN=""
+20 FOR
SET DFN=$ORDER(@GLBREF@(DFN))
IF DFN=""
QUIT
Begin DoDot:2
+21 ; If patient is deceased, quit
+22 IF $PIECE($GET(^DPT(DFN,.35)),U,1)'=""
QUIT
+23 ; If patient has no active HRNs, quit
+24 IF '$$HRN^BQIUL1(DFN)
IF '$$VTHR^BQIUL1(DFN)
QUIT
+25 ;
+26 IF $GET(SUBREG)'=""
SET QFL=0
Begin DoDot:3
+27 IF FILE'=9002241
QUIT
+28 SET RIEN=""
+29 FOR
SET RIEN=$ORDER(@GLBREF@(DFN,RIEN))
IF RIEN=""
QUIT
Begin DoDot:4
+30 IF $PIECE($GET(@GLBNOD@(RIEN,0)),U,5)=SUBREG
SET QFL=1
SET IENS=RIEN
End DoDot:4
End DoDot:3
IF 'QFL
QUIT
+31 ; Check register status
+32 IF $GET(SUBREG)=""
SET IENS=$ORDER(@GLBREF@(DFN,""))
+33 IF STEX'=""
XECUTE STEX
IF '$DATA(IENS)
QUIT
+34 SET PSTAT=$$GET1^DIQ(STFILE,IENS,STFLD,"I")
SET CSTAT=""
SET PCAT=""
+35 IF STFILE=90451.01
SET PCAT=$$GET1^DIQ(STFILE,IENS,2.3,"I")
+36 IF $ORDER(^BQIREG("C",DFN,TAG,""))'=""
SET CSTAT=$$ATAG^BQITDUTL(DFN,TAG)
+37 IF $PIECE(CSTAT,U,2)="A"
QUIT
+38 SET DATE=$PIECE($GET(^BQIPAT(DFN,20,TAG,0)),U,2)
+39 IF $ORDER(^BQIREG("C",DFN,TAG,""))'=""
QUIT
+40 IF PSTAT="U"!(PSTAT="")!(PSTAT="I")
Begin DoDot:3
+41 ; If patient is not tagged, quit
+42 IF $ORDER(^BQIPAT(DFN,20,TAG,0))=""
QUIT
+43 IF $ORDER(^BQIREG("C",DFN,TAG,""))'=""
QUIT
+44 IF TAG=3&($EXTRACT(PCAT,1)="E")!(PCAT="")
QUIT
+45 ; else build a "proposed" record
+46 DO EN^BQITDPRC(.DATA,DFN,TAG,"P",DATE,"POST INSTALL JOB",8,"Register status is "_PSTAT)
QUIT
End DoDot:3
QUIT
+47 IF $ORDER(^BQIPAT(DFN,20,TAG,0))'=""
Begin DoDot:3
+48 IF PCAT="H"!(PCAT="A")
DO EN^BQITDPRC(.DATA,DFN,TAG,"A",DATE,"POST INSTALL JOB",8,"Register status is "_PSTAT)
QUIT
+49 DO EN^BQITDPRC(.DATA,DFN,TAG,"P",DATE,"POST INSTALL JOB",8,"Register status is "_PSTAT)
End DoDot:3
+50 IF $ORDER(^BQIPAT(DFN,20,TAG,0))=""
Begin DoDot:3
+51 IF TAG=3&($EXTRACT(PCAT,1)="E")!(PCAT="")
QUIT
+52 DO EN^BQITDPRC(.DATA,DFN,TAG,"P",DATE,"POST INSTALL JOB",8,"Register status is "_PSTAT)
End DoDot:3
+53 ; Remove any temporary BQIPAT data
+54 NEW DA,DIK
+55 SET DA(1)=DFN
SET DA=TAG
SET DIK="^BQIPAT("_DA(1)_",20,"
+56 DO ^DIK
End DoDot:2
End DoDot:1
+57 ;
TG ; Set up Proposed records in BQIREG
+1 SET DFN=0
+2 FOR
SET DFN=$ORDER(^BQIPAT(DFN))
IF 'DFN
QUIT
Begin DoDot:1
+3 SET TAG=0
+4 FOR
SET TAG=$ORDER(^BQIPAT(DFN,20,TAG))
IF 'TAG
QUIT
Begin DoDot:2
+5 ; If there is already a record, quit
+6 IF $ORDER(^BQIREG("C",DFN,TAG,""))'=""
QUIT
+7 ; Get date that the tag was last identified
+8 SET DATE=$PIECE(^BQIPAT(DFN,20,TAG,0),"^",2)
+9 ; Get the tag name
+10 SET TGNM=$PIECE(^BQI(90506.2,TAG,0),"^",1)
+11 ; If the tag is CVD At Risk, then it automatically becomes 'Accepted'
+12 IF TGNM="CVD At Risk"
Begin DoDot:3
+13 DO EN^BQITDPRC(.DATA,DFN,TAG,"A",DATE,"POST INSTALL JOB",5)
+14 NEW DA,DIK
+15 SET DA(1)=DFN
SET DA=TAG
SET DIK="^BQIPAT("_DA(1)_",20,"
+16 DO ^DIK
End DoDot:3
QUIT
+17 ; Otherwise, it is a 'Proposed' tag
+18 DO EN^BQITDPRC(.DATA,DFN,TAG,"P",DATE,"POST INSTALL JOB",5)
End DoDot:2
End DoDot:1
+19 ;
CN ;Check HMS Candidate file
+1 NEW STAT,BQDA,TAG
+2 SET BQDA=0
SET TAG=3
+3 FOR
SET BQDA=$ORDER(^BKM(90451.2,BQDA))
IF 'BQDA
QUIT
Begin DoDot:1
+4 SET BQDFN=$PIECE(^BKM(90451.2,BQDA,0),U,1)
SET STAT=$PIECE(^(0),U,3)
+5 ; if the status is not NOT:NOT ACCEPTED or REM:REMOVED, quit
+6 IF STAT'="NOT"&(STAT'="REM")
Begin DoDot:2
+7 IF $ORDER(^BQIREG("C",BQDFN,TAG,""))'=""
QUIT
+8 DO EN^BQITDPRC(.DATA,BQDFN,TAG,"P",DATE,"POST INSTALL JOB",1,"Patient originally on HMS Candidate List")
End DoDot:2
QUIT
+9 SET DATE=$SELECT($PIECE(^BKM(90451.2,BQDA,0),U,5)'="":$PIECE(^(0),U,5),1:"")
+10 SET USER=$SELECT($PIECE(^BKM(90451.2,BQDA,0),U,6)'="":$PIECE(^VA(200,$PIECE(^(0),U,6),0),U,1),1:"POST INSTALL JOB")
+11 ; If the recalculate of tags created a record, delete it
+12 IF $ORDER(^BQIREG("C",BQDFN,TAG,""))'=""
Begin DoDot:2
+13 NEW DIK,DA
+14 SET DIK="^BQIREG("
SET DA=$ORDER(^BQIREG("C",BQDFN,TAG,""))
DO ^DIK
+15 SET DA(1)=BQDFN
SET DA=TAG
SET DIK="^BQIPAT("_DA(1)_",20,"
DO ^DIK
End DoDot:2
+16 DO EN^BQITDPRC(.DATA,BQDFN,TAG,"N",DATE,USER,1,"Patient on HMS Register has status Not Accepted or Removed.")
End DoDot:1
+17 ;
+18 ; Check if any HIV record is 'No Longer Valid' and reset comment
+19 NEW RIEN
+20 SET RIEN=""
+21 FOR
SET RIEN=$ORDER(^BQIREG("B",3,RIEN))
IF RIEN=""
QUIT
Begin DoDot:1
+22 SET STAT=$PIECE(^BQIREG(RIEN,0),U,3)
+23 IF STAT'="V"
QUIT
+24 SET BQIUPD(90509,RIEN_",",.06)=9
End DoDot:1
+25 DO FILE^DIE("","BQIUPD","ERROR")
+26 ;
AS ; Set any Asthma's (IEN=1) to accepted if the severity value is 2,3, or 4
+1 SET RIEN=""
+2 FOR
SET RIEN=$ORDER(^BQIREG("B",1,RIEN))
IF RIEN=""
QUIT
Begin DoDot:1
+3 SET STAT=$PIECE(^BQIREG(RIEN,0),U,3)
SET DFN=$PIECE(^(0),U,2)
+4 IF '$$ACST^BQITDUTL(STAT)
QUIT
+5 SET SEV=$$LASTSEV^APCHSAST(DFN,1)
+6 IF SEV<2
QUIT
+7 KILL BQTX
+8 SET BQIUPD(90509,RIEN_",",.03)="A"
+9 SET BQIUPD(90509,RIEN_",",.06)=9
+10 DO FILE^DIE("I","BQIUPD","ERROR")
+11 SET BQTX(1,0)="Patient's severity was "_$$LASTSEV^APCHSAST(DFN,5)
+12 DO WP^DIE(90509,RIEN_",",1,"","BQTX","ERROR")
+13 KILL BQIUPD
End DoDot:1
+14 ;
+15 ; Set up treatment prompts
+16 DO EN^BQITASK3
+17 QUIT
