BQIDCTX.m

BQIDCTX ;VNGT/HS/ALA-Taxonomy Search ; 01 Feb 2007  6:29 PM

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

 ;

 Q

 ;

TAX(DATA,PARMS,MPARMS) ;EP

 ;

 ;Description

 ;  Executable to retrieve those patients which have data in RPMS for

 ;  specified taxonomies

 ;Input

 ;  PARMS = Array of parameters and their values

 ;  MPARMS = Multiple array of a parameter

 ;Expected to return DATA

 ;

 NEW UID,II,X,TGLOB,NM,FROM,THRU,VISITS,TAX,DFN

 S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J),II=0

 S DATA=$NA(^TMP("BQIDCTX",UID)),TGLOB=$NA(^TMP("BQIDCTG",UID))

 K @DATA,@TGLOB

 ;

 NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIDCTX D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2

 ;

 I '$D(PARMS),'$D(MPARMS) Q

 ;

 S NM=""

 F  S NM=$O(PARMS(NM)) Q:NM=""  D

 . S @NM=$P(PARMS(NM),U,1)

 . F I=2:1:$L(PARMS(NM),U) Q:$P(PARMS(NM),U,I)=""  S @($P(PARMS(NM),U,I))

 ;

 ; If a single taxonomy

 I $G(TAX)'="" D TAX1 M @DATA=@TGLOB G DONE

 ;

 ; If multiple taxonomies

 I $D(MPARMS("TAX")) S TAX="" F  S TAX=$O(MPARMS("TAX",TAX)) Q:TAX=""  D

 . F I=1:1:$L(MPARMS("TAX",TAX),U) Q:$P(MPARMS("TAX",TAX),U,I)=""  S @($P(MPARMS("TAX",TAX),U,I))

 . D TAX1

 . S DFN=""

 . F  S DFN=$O(@TGLOB@(DFN)) Q:DFN=""  I @TGLOB@(DFN)<VISITS K @TGLOB@(DFN)

 . M @DATA=@TGLOB

 ;

DONE ;

 K @TREF,@TGLOB,FROM,THRU,VISITS

 Q

 ;

TAX1 ;

 ; Parameters

 ;   QN   = QMan link IEN

 ;   FREF = Target FileMan File Reference

 ;   FLD  = Target Field Number

 ;   GREF = Global reference

 ;   TREF = Taxonomy reference

 NEW GREF,TREF,QN,TAXNM,FREF,FLD,TN,XRF,IEN,VISIT,VSDTM

 S TAXNM=$P($G(^ATXAX(TAX,0)),U,1)

 S QN=$P($G(^ATXAX(TAX,0)),U,12) I QN="" Q

 S FREF=$P($G(^AMQQ(1,QN,0)),U,3) I FREF="" Q

 S FLD=$P($G(^AMQQ(1,QN,0)),U,4)

 S GREF=$$ROOT^DILFD(FREF,"",1)

 S TREF=$NA(^TMP("BQITAX",UID))

 K @TREF

 ; Build the values to look for from the taxonomy in temporary global

 D BLD^BQITUTL(TAXNM,TREF)

 ;

 S TN="" F  S TN=$O(@TREF@(TN)) Q:TN=""  D FND

 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

 ;

FND ;

 I FLD=".01" S XRF="B" ; Could be "AF" in the future

 S IEN=""

 F  S IEN=$O(@GREF@(XRF,TN,IEN),-1) Q:IEN=""  D

 . S DFN=$P($G(@GREF@(IEN,0)),U,2) I DFN="" Q

 . ; 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

 . ;

 . S VISIT=$P($G(@GREF@(IEN,0)),U,3) I VISIT="" Q

 . ; If visit has been deleted, quit

 . I $P(^AUPNVSIT(VISIT,0),U,11)=1 Q

 . S VSDTM=$P($G(^AUPNVSIT(VISIT,0)),U,1)\1 I VSDTM=0 Q

 . I $G(FROM)'="",$G(THRU)'="" S QFL=0 D  Q:QFL

 .. I VSDTM<FROM!(VSDTM>THRU) S QFL=1

 . I $G(VISITS)="" S @TGLOB@(DFN)="" Q

 . I $G(VISITS)'="" Q:$G(@TGLOB@(DFN))'<VISITS  S @TGLOB@(DFN)=$G(@TGLOB@(DFN))+1

 Q

BQIDCTX   ;VNGT/HS/ALA-Taxonomy Search ; 01 Feb 2007  6:29 PM

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

 +2       ;

 +3        QUIT 

 +4       ;

TAX(DATA,PARMS,MPARMS) ;EP

 +1       ;

 +2       ;Description

 +3       ;  Executable to retrieve those patients which have data in RPMS for

 +4       ;  specified taxonomies

 +5       ;Input

 +6       ;  PARMS = Array of parameters and their values

 +7       ;  MPARMS = Multiple array of a parameter

 +8       ;Expected to return DATA

 +9       ;

 +10       NEW UID,II,X,TGLOB,NM,FROM,THRU,VISITS,TAX,DFN

 +11       SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)

           SET II=0

 +12       SET DATA=$NAME(^TMP("BQIDCTX",UID))

           SET TGLOB=$NAME(^TMP("BQIDCTG",UID))

 +13       KILL @DATA,@TGLOB

 +14      ;

 +15      ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

           SET $ETRAP="D ERR^BQIDCTX D UNWIND^%ZTER"

 +16      ;

 +17       IF '$DATA(PARMS)

               IF '$DATA(MPARMS)

                   QUIT 

 +18      ;

 +19       SET NM=""

 +20       FOR 

               SET NM=$ORDER(PARMS(NM))

               IF NM=""

                   QUIT 

               Begin DoDot:1

 +21               SET @NM=$PIECE(PARMS(NM),U,1)

 +22               FOR I=2:1:$LENGTH(PARMS(NM),U)

                       IF $PIECE(PARMS(NM),U,I)=""

                           QUIT 

                       SET @($PIECE(PARMS(NM),U,I))

               End DoDot:1

 +23      ;

 +24      ; If a single taxonomy

 +25       IF $GET(TAX)'=""

               DO TAX1

               MERGE @DATA=@TGLOB

               GOTO DONE

 +26      ;

 +27      ; If multiple taxonomies

 +28       IF $DATA(MPARMS("TAX"))

               SET TAX=""

               FOR 

                   SET TAX=$ORDER(MPARMS("TAX",TAX))

                   IF TAX=""

                       QUIT 

                   Begin DoDot:1

 +29                   FOR I=1:1:$LENGTH(MPARMS("TAX",TAX),U)

                           IF $PIECE(MPARMS("TAX",TAX),U,I)=""

                               QUIT 

                           SET @($PIECE(MPARMS("TAX",TAX),U,I))

 +30                   DO TAX1

 +31                   SET DFN=""

 +32                   FOR 

                           SET DFN=$ORDER(@TGLOB@(DFN))

                           IF DFN=""

                               QUIT 

                           IF @TGLOB@(DFN)<VISITS

                               KILL @TGLOB@(DFN)

 +33                   MERGE @DATA=@TGLOB

                   End DoDot:1

 +34      ;

DONE      ;

 +1        KILL @TREF,@TGLOB,FROM,THRU,VISITS

 +2        QUIT 

 +3       ;

TAX1      ;

 +1       ; Parameters

 +2       ;   QN   = QMan link IEN

 +3       ;   FREF = Target FileMan File Reference

 +4       ;   FLD  = Target Field Number

 +5       ;   GREF = Global reference

 +6       ;   TREF = Taxonomy reference

 +7        NEW GREF,TREF,QN,TAXNM,FREF,FLD,TN,XRF,IEN,VISIT,VSDTM

 +8        SET TAXNM=$PIECE($GET(^ATXAX(TAX,0)),U,1)

 +9        SET QN=$PIECE($GET(^ATXAX(TAX,0)),U,12)

           IF QN=""

               QUIT 

 +10       SET FREF=$PIECE($GET(^AMQQ(1,QN,0)),U,3)

           IF FREF=""

               QUIT 

 +11       SET FLD=$PIECE($GET(^AMQQ(1,QN,0)),U,4)

 +12       SET GREF=$$ROOT^DILFD(FREF,"",1)

 +13       SET TREF=$NAME(^TMP("BQITAX",UID))

 +14       KILL @TREF

 +15      ; Build the values to look for from the taxonomy in temporary global

 +16       DO BLD^BQITUTL(TAXNM,TREF)

 +17      ;

 +18       SET TN=""

           FOR 

               SET TN=$ORDER(@TREF@(TN))

               IF TN=""

                   QUIT 

               DO FND

 +19       QUIT 

 +20      ;

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 

 +7       ;

FND       ;

 +1       ; Could be "AF" in the future

           IF FLD=".01"

               SET XRF="B"

 +2        SET IEN=""

 +3        FOR 

               SET IEN=$ORDER(@GREF@(XRF,TN,IEN),-1)

               IF IEN=""

                   QUIT 

               Begin DoDot:1

 +4                SET DFN=$PIECE($GET(@GREF@(IEN,0)),U,2)

                   IF DFN=""

                       QUIT 

 +5       ; User may now select Living, Deceased or both as a filter so

 +6       ; if no filters defined assume living patients otherwise let filter decide

 +7       ;I $O(^BQICARE(OWNR,1,PLIEN,15,0))="",$P($G(^DPT(DFN,.35)),U,1)'="" Q

 +8       ; If patient has no active HRNs, quit

 +9                IF '$$HRN^BQIUL1(DFN)

                       QUIT 

 +10      ; If patient has no visit in last 3 years, quit

 +11      ;I '$$VTHR^BQIUL1(DFN) Q

 +12      ;

 +13               SET VISIT=$PIECE($GET(@GREF@(IEN,0)),U,3)

                   IF VISIT=""

                       QUIT 

 +14      ; If visit has been deleted, quit

 +15               IF $PIECE(^AUPNVSIT(VISIT,0),U,11)=1

                       QUIT 

 +16               SET VSDTM=$PIECE($GET(^AUPNVSIT(VISIT,0)),U,1)\1

                   IF VSDTM=0

                       QUIT 

 +17               IF $GET(FROM)'=""

                       IF $GET(THRU)'=""

                           SET QFL=0

                           Begin DoDot:2

 +18                           IF VSDTM<FROM!(VSDTM>THRU)

                                   SET QFL=1

                           End DoDot:2

                           IF QFL

                               QUIT 

 +19               IF $GET(VISITS)=""

                       SET @TGLOB@(DFN)=""

                       QUIT 

 +20               IF $GET(VISITS)'=""

                       IF $GET(@TGLOB@(DFN))'<VISITS

                           QUIT 

                       SET @TGLOB@(DFN)=$GET(@TGLOB@(DFN))+1

               End DoDot:1

 +21       QUIT