BQIDCREG ;PRXM/HC/ALA-RPMS Register Patients ; 04 Nov 2005 11:04 AM
;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
;
Q
;
MYP(DATA,PARMS,MPARMS) ;EP
;
;Description
; Executable to retrieve those patients who are on a specified register
;Input
; PARMS = Array of parameters and their values
; MPARMS = Multiple array of a parameter
;Expected to return DATA
;
NEW UID,NM,REGIEN,RDATA,FILE,FIELD,XREF,GLBREF,DFN,GLBNOD,RIEN,QFL,SUBREG
NEW II,X
NEW STAT,PSTAT,STFILE,STFLD,STEX,IENS
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J),II=0
S DATA=$NA(^TMP("BQIDCREG",UID))
K @DATA
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIDCREG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S NM=""
F S NM=$O(PARMS(NM)) Q:NM="" S @NM=PARMS(NM)
;
FND ; Determine where to find the patient cross-reference for the
; specified registry PARMS("REG")
;Parameters
; REGIEN = Registry internal entry number
; FILE = File number where registry resides
; FIELD = Field number where patient is defined in the registry
; XREF = The cross-reference of the patient in the registry file
; GLBREF = The global reference of the patient cross-reference
; GLBNOD = Closed root of the global
;
S REGIEN=$G(PARMS("REG")) I REGIEN="" Q
S RDATA=^BQI(90507,REGIEN,0)
S FILE=$P(RDATA,"^",7),FIELD=$P(RDATA,"^",5),XREF=$P(RDATA,"^",6)
S STFILE=$P(RDATA,"^",15),STFLD=$P(RDATA,"^",14),STEX=$G(^BQI(90507,REGIEN,1))
I $G(SUBREG)="" 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
. ; User may now select Living, Deceased or both as a filter so
. ; if no filters defined assume living patients otherwise let filter decide
. ;I $O(^BQICARE(OWNR,1,PLIEN,15,0))="",$P($G(^DPT(DFN,.35)),U,1)'="" Q
. ; If patient has no active HRNs, quit
. I '$$HRN^BQIUL1(DFN) Q
. ; If patient has no visit in last 3 years, quit
. ;I '$$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 $D(PARMS("STAT"))!$D(MPARMS("STAT")) S QFL=0 D Q:'QFL
.. ;S IENS=$O(@GLBREF@(DFN,""))
.. I $G(SUBREG)="" S IENS=$O(@GLBREF@(DFN,""))
.. I STEX'="" X STEX Q:'$D(IENS)
.. I STEX="" S PSTAT=$$GET1^DIQ(STFILE,IENS,STFLD,"I")
.. I $D(PARMS("STAT")),PSTAT=PARMS("STAT") S QFL=1 Q
.. S STAT=""
.. F S STAT=$O(MPARMS("STAT",STAT)) Q:STAT="" I PSTAT=STAT S QFL=1 Q
. S @DATA@(DFN)=""
Q
;
HMS ; Set IENS for HMS Registry
N DA
S DA(1)=$O(^BKM(90451,"B",DFN,"")) Q:'DA(1)
S DA=$O(^BKM(90451,DA(1),1,0)) Q:'DA
S IENS=$$IENS^DILF(.DA)
S PSTAT=$$GET1^DIQ(STFILE,IENS,STFLD,"I")
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)=$C(31)
Q
BQIDCREG ;PRXM/HC/ALA-RPMS Register Patients ; 04 Nov 2005 11:04 AM
+1 ;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
+2 ;
+3 QUIT
+4 ;
MYP(DATA,PARMS,MPARMS) ;EP
+1 ;
+2 ;Description
+3 ; Executable to retrieve those patients who are on a specified register
+4 ;Input
+5 ; PARMS = Array of parameters and their values
+6 ; MPARMS = Multiple array of a parameter
+7 ;Expected to return DATA
+8 ;
+9 NEW UID,NM,REGIEN,RDATA,FILE,FIELD,XREF,GLBREF,DFN,GLBNOD,RIEN,QFL,SUBREG
+10 NEW II,X
+11 NEW STAT,PSTAT,STFILE,STFLD,STEX,IENS
+12 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
SET II=0
+13 SET DATA=$NAME(^TMP("BQIDCREG",UID))
+14 KILL @DATA
+15 ;
+16 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIDCREG D UNWIND^%ZTER"
+17 SET NM=""
+18 FOR
SET NM=$ORDER(PARMS(NM))
IF NM=""
QUIT
SET @NM=PARMS(NM)
+19 ;
FND ; Determine where to find the patient cross-reference for the
+1 ; specified registry PARMS("REG")
+2 ;Parameters
+3 ; REGIEN = Registry internal entry number
+4 ; FILE = File number where registry resides
+5 ; FIELD = Field number where patient is defined in the registry
+6 ; XREF = The cross-reference of the patient in the registry file
+7 ; GLBREF = The global reference of the patient cross-reference
+8 ; GLBNOD = Closed root of the global
+9 ;
+10 SET REGIEN=$GET(PARMS("REG"))
IF REGIEN=""
QUIT
+11 SET RDATA=^BQI(90507,REGIEN,0)
+12 SET FILE=$PIECE(RDATA,"^",7)
SET FIELD=$PIECE(RDATA,"^",5)
SET XREF=$PIECE(RDATA,"^",6)
+13 SET STFILE=$PIECE(RDATA,"^",15)
SET STFLD=$PIECE(RDATA,"^",14)
SET STEX=$GET(^BQI(90507,REGIEN,1))
+14 IF $GET(SUBREG)=""
SET SUBREG=$PIECE(RDATA,U,9)
+15 SET GLBREF=$$ROOT^DILFD(FILE,"")_XREF_")"
+16 SET GLBNOD=$$ROOT^DILFD(FILE,"",1)
+17 IF GLBNOD=""
QUIT
+18 ;
+19 IF '$DATA(@GLBNOD@(0))
QUIT
+20 ;
+21 SET DFN=""
+22 FOR
SET DFN=$ORDER(@GLBREF@(DFN))
IF DFN=""
QUIT
Begin DoDot:1
+23 ; If patient is deceased, quit
+24 ; User may now select Living, Deceased or both as a filter so
+25 ; if no filters defined assume living patients otherwise let filter decide
+26 ;I $O(^BQICARE(OWNR,1,PLIEN,15,0))="",$P($G(^DPT(DFN,.35)),U,1)'="" Q
+27 ; If patient has no active HRNs, quit
+28 IF '$$HRN^BQIUL1(DFN)
QUIT
+29 ; If patient has no visit in last 3 years, quit
+30 ;I '$$VTHR^BQIUL1(DFN) Q
+31 ;
+32 IF $GET(SUBREG)'=""
SET QFL=0
Begin DoDot:2
+33 ;Q:FILE'=9002241
+34 SET RIEN=""
+35 FOR
SET RIEN=$ORDER(@GLBREF@(DFN,RIEN))
IF RIEN=""
QUIT
Begin DoDot:3
+36 IF $PIECE($GET(@GLBNOD@(RIEN,0)),U,5)=SUBREG
SET QFL=1
SET IENS=RIEN
End DoDot:3
End DoDot:2
IF 'QFL
QUIT
+37 ; Check register status
+38 IF $DATA(PARMS("STAT"))!$DATA(MPARMS("STAT"))
SET QFL=0
Begin DoDot:2
+39 ;S IENS=$O(@GLBREF@(DFN,""))
+40 IF $GET(SUBREG)=""
SET IENS=$ORDER(@GLBREF@(DFN,""))
+41 IF STEX'=""
XECUTE STEX
IF '$DATA(IENS)
QUIT
+42 IF STEX=""
SET PSTAT=$$GET1^DIQ(STFILE,IENS,STFLD,"I")
+43 IF $DATA(PARMS("STAT"))
IF PSTAT=PARMS("STAT")
SET QFL=1
QUIT
+44 SET STAT=""
+45 FOR
SET STAT=$ORDER(MPARMS("STAT",STAT))
IF STAT=""
QUIT
IF PSTAT=STAT
SET QFL=1
QUIT
End DoDot:2
IF 'QFL
QUIT
+46 SET @DATA@(DFN)=""
End DoDot:1
+47 QUIT
+48 ;
HMS ; Set IENS for HMS Registry
+1 NEW DA
+2 SET DA(1)=$ORDER(^BKM(90451,"B",DFN,""))
IF 'DA(1)
QUIT
+3 SET DA=$ORDER(^BKM(90451,DA(1),1,0))
IF 'DA
QUIT
+4 SET IENS=$$IENS^DILF(.DA)
+5 SET PSTAT=$$GET1^DIQ(STFILE,IENS,STFLD,"I")
+6 QUIT
+7 ;
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)=$CHAR(31)
+6 QUIT
