BQIPTREG ;PRXM/HC/ALA-RPMS Registers a Patient is on ; 07 Nov 2005 1:59 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
Q
;
REG(DATA,DFN) ; EP -- BQI PATIENT RPMS REGISTERS
;
;Find all the registers a patient is on
;
;Description
; For all the active designated registers, see if a patient is on it
;Input
; DFN - Patient internal entry number
;
NEW REGIEN,RDATA,FILE,FIELD,XREF,GLREF,REGISTER,BQI,UID,TITLE,STAT
NEW GLBREF,RIEN,BQIREG,DX,RGCAT,RGDUZ,STATDT,KEY,RACC,NMSP,X,IEN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTREG",UID))
K @DATA
;
S BQI=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTREG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(BQI)="T00040COMBINED^T00004ANAMESPACE^T00030REG_TITLE^T00015REG_STAT^D00030REG_STATDT^T00030REG_CAT^T00035REG_CREATOR^T00003REG_ACCESS"_$C(30)
;
; for each defined registry index definition, determine if this patient is in
; that registry
S REGIEN=0
F S REGIEN=$O(^BQI(90507,REGIEN)) Q:'REGIEN D
. Q:$$GET1^DIQ(90507,REGIEN_",",.08,"I")=1
. S RDATA=^BQI(90507,REGIEN,0)
. S FILE=$P(RDATA,"^",7),FIELD=$P(RDATA,"^",5),XREF=$P(RDATA,"^",6)
. S TITLE=$P(RDATA,"^",1),KEY=$P(RDATA,"^",10),NMSP=$P(RDATA,"^",13)
. I '$$VFILE^DILFD(FILE) Q
. S GLBREF=$$ROOT^DILFD(FILE,"")_XREF_")"
. Q:'$D(@GLBREF@(DFN))
. ; HMS Registry
. I FILE=90451 D
.. S REGISTER=$$HIVIEN^BKMIXX3()
.. S IEN=$O(@GLBREF@(DFN,""))
.. NEW DA,IENS
.. S DA(1)=IEN,DA=REGISTER,IENS=$$IENS^DILF(.DA)
.. S STAT=$$GET1^DIQ(90451.01,IENS,.5,"E")
.. S STATDT=$$GET1^DIQ(90451.01,IENS,.75,"I")
.. S RGCAT=$$GET1^DIQ(90451.01,IENS,2.3,"E")
.. S RGDUZ=$$GET1^DIQ(90451.01,IENS,.025,"E")
.. S RACC=$$KEYCHK^BQIULSC(KEY,DUZ)
.. D STOR
. ; CMS Registry
. I FILE=9002241 D
.. S TITLE=$$GET1^DIQ(90507,REGIEN_",",.01,"E")
.. S REGISTER=$$GET1^DIQ(90507,REGIEN_",",.09,"E")
.. I REGISTER="" D ACM Q
.. D CMSI^BQIUL1(REGISTER) S BQIREG=+Y K X,Y
.. I BQIREG<1 Q
.. S DX=$O(^ACM(44,"AC",BQIREG,DFN,"")) Q:DX=""
.. S IEN=^ACM(44,"AC",BQIREG,DFN,DX)
.. S RIEN=$$GET1^DIQ(9002244,IEN_",",.03,"I")
.. S STAT=$$GET1^DIQ(9002241,RIEN_",",1,"E")
.. S STATDT=$$GET1^DIQ(9002241,RIEN_",",11,"I")
.. S RGCAT=$$GET1^DIQ(9002244,IEN_",",.01,"E")
.. S RGDUZ=$$GET1^DIQ(9002241.1,BQIREG_",",3.5,"E")
.. S RACC=$$KEYCHK^BQIULSC(KEY,DUZ)
.. D STOR
. ;
. I FILE=90181.01 D
.. S TITLE=$$GET1^DIQ(90507,REGIEN_",",.01,"E")
.. S IEN=DFN
.. S STAT=$$GET1^DIQ(FILE,IEN_",",.02,"E"),STATDT="",RGCAT=""
.. S RGDUZ=$$GET1^DIQ(FILE,IEN_",",.11,"E")
.. S RACC=$$KEYCHK^BQIULSC(KEY,DUZ)
.. D STOR
;
S BQI=BQI+1,@DATA@(BQI)=$C(31)
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(BQI),$D(DATA) S BQI=BQI+1,@DATA@(BQI)=$C(31)
Q
;
STOR ; Store value
S BQI=BQI+1
S @DATA@(BQI)=NMSP_": "_TITLE_"^"_NMSP_"^"_TITLE_"^"_STAT_"^"_$$FMTE^BQIUL1(STATDT)_"^"_RGCAT_"^"_RGDUZ_"^"_$S(RACC=-1:"N/A",RACC=1:"Y",1:"N")_$C(30)
Q
;
ACM ; Get all sub-registers a patient is on
S RACC=$$KEYCHK^BQIULSC(KEY,DUZ)
S RIEN=""
F S RIEN=$O(^ACM(41,"C",DFN,RIEN)) Q:RIEN="" D
. S STAT=$$GET1^DIQ(9002241,RIEN_",",1,"E")
. S STATDT=$$GET1^DIQ(9002241,RIEN_",",11,"I")
. S IEN=$O(^ACM(44,"D",RIEN,"")),RGCAT=""
. I IEN'="" S RGCAT=$$GET1^DIQ(9002244,IEN_",",.01,"E")
. S BQIREG=$$GET1^DIQ(9002241,RIEN_",",.01,"I") I BQIREG="" Q
. S RGDUZ=$$GET1^DIQ(9002241.1,BQIREG_",",3.5,"E")
. S TITLE=$$GET1^DIQ(9002241,RIEN_",",.01,"E")
. D STOR
Q
BQIPTREG ;PRXM/HC/ALA-RPMS Registers a Patient is on ; 07 Nov 2005 1:59 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 QUIT
+4 ;
REG(DATA,DFN) ; EP -- BQI PATIENT RPMS REGISTERS
+1 ;
+2 ;Find all the registers a patient is on
+3 ;
+4 ;Description
+5 ; For all the active designated registers, see if a patient is on it
+6 ;Input
+7 ; DFN - Patient internal entry number
+8 ;
+9 NEW REGIEN,RDATA,FILE,FIELD,XREF,GLREF,REGISTER,BQI,UID,TITLE,STAT
+10 NEW GLBREF,RIEN,BQIREG,DX,RGCAT,RGDUZ,STATDT,KEY,RACC,NMSP,X,IEN
+11 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+12 SET DATA=$NAME(^TMP("BQIPTREG",UID))
+13 KILL @DATA
+14 ;
+15 SET BQI=0
+16 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTREG D UNWIND^%ZTER"
+17 ;
+18 SET @DATA@(BQI)="T00040COMBINED^T00004ANAMESPACE^T00030REG_TITLE^T00015REG_STAT^D00030REG_STATDT^T00030REG_CAT^T00035REG_CREATOR^T00003REG_ACCESS"_$CHAR(30)
+19 ;
+20 ; for each defined registry index definition, determine if this patient is in
+21 ; that registry
+22 SET REGIEN=0
+23 FOR
SET REGIEN=$ORDER(^BQI(90507,REGIEN))
IF 'REGIEN
QUIT
Begin DoDot:1
+24 IF $$GET1^DIQ(90507,REGIEN_",",.08,"I")=1
QUIT
+25 SET RDATA=^BQI(90507,REGIEN,0)
+26 SET FILE=$PIECE(RDATA,"^",7)
SET FIELD=$PIECE(RDATA,"^",5)
SET XREF=$PIECE(RDATA,"^",6)
+27 SET TITLE=$PIECE(RDATA,"^",1)
SET KEY=$PIECE(RDATA,"^",10)
SET NMSP=$PIECE(RDATA,"^",13)
+28 IF '$$VFILE^DILFD(FILE)
QUIT
+29 SET GLBREF=$$ROOT^DILFD(FILE,"")_XREF_")"
+30 IF '$DATA(@GLBREF@(DFN))
QUIT
+31 ; HMS Registry
+32 IF FILE=90451
Begin DoDot:2
+33 SET REGISTER=$$HIVIEN^BKMIXX3()
+34 SET IEN=$ORDER(@GLBREF@(DFN,""))
+35 NEW DA,IENS
+36 SET DA(1)=IEN
SET DA=REGISTER
SET IENS=$$IENS^DILF(.DA)
+37 SET STAT=$$GET1^DIQ(90451.01,IENS,.5,"E")
+38 SET STATDT=$$GET1^DIQ(90451.01,IENS,.75,"I")
+39 SET RGCAT=$$GET1^DIQ(90451.01,IENS,2.3,"E")
+40 SET RGDUZ=$$GET1^DIQ(90451.01,IENS,.025,"E")
+41 SET RACC=$$KEYCHK^BQIULSC(KEY,DUZ)
+42 DO STOR
End DoDot:2
+43 ; CMS Registry
+44 IF FILE=9002241
Begin DoDot:2
+45 SET TITLE=$$GET1^DIQ(90507,REGIEN_",",.01,"E")
+46 SET REGISTER=$$GET1^DIQ(90507,REGIEN_",",.09,"E")
+47 IF REGISTER=""
DO ACM
QUIT
+48 DO CMSI^BQIUL1(REGISTER)
SET BQIREG=+Y
KILL X,Y
+49 IF BQIREG<1
QUIT
+50 SET DX=$ORDER(^ACM(44,"AC",BQIREG,DFN,""))
IF DX=""
QUIT
+51 SET IEN=^ACM(44,"AC",BQIREG,DFN,DX)
+52 SET RIEN=$$GET1^DIQ(9002244,IEN_",",.03,"I")
+53 SET STAT=$$GET1^DIQ(9002241,RIEN_",",1,"E")
+54 SET STATDT=$$GET1^DIQ(9002241,RIEN_",",11,"I")
+55 SET RGCAT=$$GET1^DIQ(9002244,IEN_",",.01,"E")
+56 SET RGDUZ=$$GET1^DIQ(9002241.1,BQIREG_",",3.5,"E")
+57 SET RACC=$$KEYCHK^BQIULSC(KEY,DUZ)
+58 DO STOR
End DoDot:2
+59 ;
+60 IF FILE=90181.01
Begin DoDot:2
+61 SET TITLE=$$GET1^DIQ(90507,REGIEN_",",.01,"E")
+62 SET IEN=DFN
+63 SET STAT=$$GET1^DIQ(FILE,IEN_",",.02,"E")
SET STATDT=""
SET RGCAT=""
+64 SET RGDUZ=$$GET1^DIQ(FILE,IEN_",",.11,"E")
+65 SET RACC=$$KEYCHK^BQIULSC(KEY,DUZ)
+66 DO STOR
End DoDot:2
End DoDot:1
+67 ;
+68 SET BQI=BQI+1
SET @DATA@(BQI)=$CHAR(31)
+69 QUIT
+70 ;
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(BQI)
IF $DATA(DATA)
SET BQI=BQI+1
SET @DATA@(BQI)=$CHAR(31)
+6 QUIT
+7 ;
STOR ; Store value
+1 SET BQI=BQI+1
+2 SET @DATA@(BQI)=NMSP_": "_TITLE_"^"_NMSP_"^"_TITLE_"^"_STAT_"^"_$$FMTE^BQIUL1(STATDT)_"^"_RGCAT_"^"_RGDUZ_"^"_$SELECT(RACC=-1:"N/A",RACC=1:"Y",1:"N")_$CHAR(30)
+3 QUIT
+4 ;
ACM ; Get all sub-registers a patient is on
+1 SET RACC=$$KEYCHK^BQIULSC(KEY,DUZ)
+2 SET RIEN=""
+3 FOR
SET RIEN=$ORDER(^ACM(41,"C",DFN,RIEN))
IF RIEN=""
QUIT
Begin DoDot:1
+4 SET STAT=$$GET1^DIQ(9002241,RIEN_",",1,"E")
+5 SET STATDT=$$GET1^DIQ(9002241,RIEN_",",11,"I")
+6 SET IEN=$ORDER(^ACM(44,"D",RIEN,""))
SET RGCAT=""
+7 IF IEN'=""
SET RGCAT=$$GET1^DIQ(9002244,IEN_",",.01,"E")
+8 SET BQIREG=$$GET1^DIQ(9002241,RIEN_",",.01,"I")
IF BQIREG=""
QUIT
+9 SET RGDUZ=$$GET1^DIQ(9002241.1,BQIREG_",",3.5,"E")
+10 SET TITLE=$$GET1^DIQ(9002241,RIEN_",",.01,"E")
+11 DO STOR
End DoDot:1
+12 QUIT
