Routine: BQIPTREG

BQIPTREG ;PRXM/HC/ALA-RPMS Registers a Patient is on ; 07 Nov 2005  1:59 PM

 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011

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)

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)

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)

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

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

BQIPTREG.m