source: ccr/trunk/p/GPLRIMA.m@ 148

GPLRIMA   ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08
 ;;0.1;CCDCCR;nopatch;noreleasedate
 ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
 ;General Public License See attached copy of the License.
 ;
 ;This program is free software; you can redistribute it and/or modify
 ;it under the terms of the GNU General Public License as published by
 ;the Free Software Foundation; either version 2 of the License, or
 ;(at your option) any later version.
 ;
 ;This program is distributed in the hope that it will be useful,
 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;GNU General Public License for more details.
 ;
 ;You should have received a copy of the GNU General Public License along
 ;with this program; if not, write to the Free Software Foundation, Inc.,
 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 ;
 ; THESE ROUTINES EXAMINE ONE OR MORE, UP TO ALL, OF THE PATIENTS ON THE
 ; SYSTEM TO DETERMINE HOW COMPLETE THE RESULTING CCR OR CCD WOULD BE FOR
 ; THESE PATIENTS. IT BEGINS TO MEASURE "HL7 RIM COHERENCE" WHICH IS HOW USEFUL
 ; THE VARIABLES WILL BE TO A RIM-MODELED APPLICATION AFTER THEY ARE
 ; CONVEYED VIA THE CCR OR CCD.
 ; FACTORS THAT AFFECT RIM COHERENCE INCLUDE:
 ;    1. THE PRESENSE OF CLINICAL DATA IN A SECTION
 ;    2. ARE THE DATA ELEMENTS TIME-BOUND
 ;    3. ARE THE DATA ELEMENTS CODED WITH SNOMED OR LOINC ETC
 ;    4. ARE SOURCE ACTORS ASSOCIATED WITH THE DATA ELEMENTS
 ;    5. ARE ACTORS IDENTIFIED REGARDING THEIR ROLE
 ;    .. AND OTHER FACTORS YET TO BE DETERMINED
 ;
 ;    SINCE THESE MEASUREMENTS ARE DONE AT THE VARIABLE LEVEL, THEY
 ;    REFLECT ON RIM COHERENCE WHETHER THE CCR OR THE CCD IS USED FOR
 ;    CONVEYANCE TO THE RIM APPLICATION.
 ;
 ;
ANALYZE(BEGDFN,DFNCNT) ; RIM COHERANCE ANALYSIS ROUTINE
    ; BEGINS AT BEGDFN AND GOES FOR DFNCNT PATIENTS
    ; TO RESUME AT NEXT PATIENT, USE BEGDFN=""
    ; USE RESET^GPLRIMA TO RESET TO TOP OF PATIENT LIST
    ;
    N RIMARY,RIMTMP,RIMI,RIMDFN,RATTR
    N CCRGLO
    D ASETUP ; SET UP VARIABLES AND GLOBALS
    D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE
    I '$D(@RIMBASE@("RESUME")) S @RIMBASE@("RESUME")=$O(^DPT(0)) ; FIRST TIME
    S RESUME=@RIMBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN
    S RIMDFN=BEGDFN ; BEGIN WITH THE BEGDFN PATIENT
    I RIMDFN="" S RIMDFN=RESUME
    I +RIMDFN=0 D  Q  ; AT THE END OF THE PATIENTS
    . W "END OF PATIENT LIST, CALL RESET^GPLRIMA",!
    F RIMI=1:1:DFNCNT  D  Q:+RIMDFN=0  ; FOR DFNCNT NUMBER OF PATIENTS OR END
    . D CCRRPC^GPLCCR(.CCRGLO,RIMDFN,"CCR","","","") ;PROCESS THE CCR
    . W RIMDFN,!
    . K @RIMBASE@("VARS",RIMDFN) ; CLEAR OUT OLD VARS
    . ;
    . ; COPY ALL THE VARIABLES TO THE RIM MAP AREA INDEXED BY PATIENT
    . ;
    . I $D(^TMP("GPLCCR",$J,"PROBVALS",1)) D  ; PROBLEM VARS EXISTS
    . . M @RIMBASE@("VARS",RIMDFN,"PROBLEMS")=^TMP("GPLCCR",$J,"PROBVALS")
    . . S @RIMBASE@("VARS",RIMDFN,"PROBLEMS",0)=^TMP("GPLCCR",$J,"PROBVALS",0)
    . I $D(^TMP("GPLCCR",$J,"VITALS",1)) D  ; VITALS VARS EXISTS
    . . M @RIMBASE@("VARS",RIMDFN,"VITALS")=^TMP("GPLCCR",$J,"VITALS")
    . I $D(^TMP("GPLCCR",$J,"MEDICATIONS",1)) D  ; MEDS VARS EXISTS
    . . M @RIMBASE@("VARS",RIMDFN,"MEDS")=^TMP("GPLCCR",$J,"MEDICATIONS")
    . K ^TMP("GPLCCR",$J) ; KILL WORK AREA FOR CCR BUILDING
    . ;
    . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP
    . ;
    . S RATTR=$$SETATTR(RIMDFN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS
    . S @RIMBASE@("ATTR",RIMDFN)=RATTR ; SAVE THE ATRIBUTES FOR THIS PAT
    . ;
    . ; INCREMENT THE COUNT OF PATIENTS WITH THESE ATTRIBUTES IN ATTRTBL
    . ;
    . ; I '$D(@RIMBASE@("ATTRTBL",RATTR)) D  ; IF FIRST PAT WITH THESE ATTRS
    . ; . S @RIMBASE@("ATTRTBL",RATTR)=0 ; DEFAULT VALUE TO BE INCREMENTED
    . ; S @RIMBASE@("ATTRTBL",RATTR)=@RIMBASE@("ATTRTBL",RATTR)+1 ; INCREMENT
    . ;
    . N CATNAME,CATTBL
    . ; S CATBASE=$NA(@RIMBASE@("ANALYSIS"))
    . S CATNAME=""
    . D CPUSH(.CATNAME,RIMBASE,"RIMTBL",RIMDFN,RATTR) ; ADD TO CATEGORY
    . W "CATEGORY NAME: ",CATNAME,!
    . ;
    . F  S RIMDFN=$O(^DPT(RIMDFN)) Q:'$$PTST^CCRSYS(RIMDFN) ; NEXT PATIENT
    . ; PTST TESTS TO SEE IF PATIENT WAS MERGED
    . ; IF CCRTEST=0, PTST WILL CHECK TO SEE IF THIS IS A TEST PATIENT
    . ; AND WE SKIP IT
    . S @RIMBASE@("RESUME")=RIMDFN ; WHERE WE ARE LEAVING OFF THIS RUN
    ; D PARY^GPLXPATH(@RIMBASE@("ATTRTBL"))
    Q
    ;
SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS
    N SBASE,SATTR
    S SBASE=$NA(@RIMBASE@("VARS",SDFN))
    D APOST("SATTR","RIMTBL","HEADER")
    I $D(@SBASE@("PROBLEMS",1)) D  ;
    . D APOST("SATTR","RIMTBL","PROBLEMS")
    . ; W "POSTING PROBLEMS",!
    I $D(@SBASE@("VITALS",1)) D APOST("SATTR","RIMTBL","VITALS")
    I $D(@SBASE@("MEDS",1)) D APOST("SATTR","RIMTBL","MEDS")
    D APOST("SATTR","RIMTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED
    W "ATTRIBUTES: ",SATTR,!
    Q SATTR
    ;
RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES
    K ^TMP("GPLRIM","RESUME")
    K ^TMP("GPLRIM")
    Q
    ;
CLIST ; LIST THE CATEGORIES
    ;
    I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
    N CLBASE,CLNUM,ZI,CLIDX
    S CLBASE=$NA(@RIMBASE@("RIMTBL","CATS"))
    S CLNUM=@CLBASE@(0)
    F ZI=1:1:CLNUM D  ; LOOP THROUGH THE CATEGORIES
    . S CLIDX=@CLBASE@(ZI)
    . W "(",$P(@CLBASE@(CLIDX),"^",1)
    . W ":",$P(@CLBASE@(CLIDX),"^",2),") "
    . W CLIDX,!
    ; D PARY^GPLXPATH(CLBASE)
    Q
    ;
CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES
    ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT
    ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE
    ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME
    ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES,
    ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X"
    ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES
    ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY
    ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING
    ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY
    ; NUMBER IE CTBL_X(CDFN)=""
    ;
    ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST
    S CCTBL=$NA(@CBASE@(CTBL,"CATS"))
    W "CBASE: ",CCTBL,!
    ;
    I '$D(@CCTBL@(CATTR)) D  ; FIRST PATIENT IN THIS CATEGORY
    . D PUSH^GPLXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY
    . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY
    . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT
    . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY
    . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME
    . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0
    ;
    S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY
    S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT
    S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK
    ;
    S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED
    ;
    S CPATLIST=$NA(@CBASE@(CTBL,"PATS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT
    W "PATS BASE: ",CPATLIST,!
    S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST
    ;
    Q
    ;
CCOUNT ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE
    ;
    I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
    N ZI,ZJ,ZCNT,ZIDX,ZCAT,ZATR,ZTOT
    S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES
    S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS
    S ZTOT=0 ; INITIALIZE OVERALL TOTAL
    F ZI=1:1:@ZCBASE@(0) D  ; FOR ALL CATS
    . S ZCNT=0
    . S ZATR=@ZCBASE@(ZI) ; THE ATTRIBUTE OF THE CATEGORY
    . S ZCAT=$P(@ZCBASE@(ZATR),"^",1) ; USE IT TO LOOK UP THE CATEGORY NAME
    . ; S ZIDX=$O(@ZPBASE@(ZCAT,"")) ; FIRST PATIENT IN LIST
    . ; F ZJ=0:0 D  Q:$O(@ZPBASE@(ZCAT,ZIDX))="" ; ALL PATIENTS IN THE LISTS
    . ; . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT
    . ; . W ZCAT," DFN:",ZIDX," COUNT:",ZCNT,!
    . ; . S ZIDX=$O(@ZPBASE@(ZCAT,ZIDX))
    . S ZCNT=$$CNTLST($NA(@ZPBASE@(ZCAT)))
    . S $P(@ZCBASE@(ZATR),"^",2)=ZCNT ; UPDATE THE COUNT IN THE CAT RECORD
    . S ZTOT=ZTOT+ZCNT
    W "TOTAL: ",ZTOT,!
    Q
    ;
CNTLST(INLST) ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST
    ; INLST IS PASSED BY NAME
    N ZI,ZDX,ZCOUNT
    W INLST,!
    S ZCOUNT=0
    S ZDX=""
    F ZI=$O(@INLST@(ZDX)):0 D  Q:$O(@INLST@(ZDX))=""  ; LOOP UNTIL THE END
    . S ZCOUNT=ZCOUNT+1
    . S ZDX=$O(@INLST@(ZDX))
    . W "ZDX:",ZDX," ZCNT:",ZCOUNT,!
    Q ZCOUNT
    ;
XCPAT(CPATCAT) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT
    ;
    I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
    N ZI,ZJ,ZC,ZPATBASE
    S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT))
    S ZI=""
    F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
    . S ZI=$O(@ZPATBASE@(ZI))
    . D XPAT^GPLCCR(ZI,"","") ; EXPORT THE PATIENT TO A FILE
    Q
    ;
CPAT(CPATCAT) ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT
    ;
    I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
    N ZI,ZJ,ZC,ZPATBASE
    S ZC=0 ; COUNT FOR SPACING THE PRINTOUT
    S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT))
    S ZI=""
    F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
    . S ZI=$O(@ZPATBASE@(ZI))
    . S ZC=ZC+1 ; INCREMENT OUTPUT PER LINE COUNT
    . W ZI," "
    . I ZC=10 D  ; NEW LINE
    . . S ZC=0
    . . W !
    Q
    ;
PATC(DFN) ; DISPLAY THE CATEGORY FOR THIS PATIENT
    ;
    N ATTR S ATTR=""
    I '$D(^TMP("GPLRIM","ATTR",DFN)) D  ; RIM VARS NOT PRESENT
    . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT
    S ATTR=^TMP("GPLRIM","ATTR",DFN)
    I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q  ;NO ATTRIBUTES FOUND
    I $D(^TMP("GPLRIM","RIMTBL","CATS",ATTR)) D  ; FOUND A CAT
    . N CAT
    . S CAT=$P(^TMP("GPLRIM","RIMTBL","CATS",ATTR),U,1) ; LOOK UP THE CAT
    . W CAT,": ",ATTR,!
    Q
    ;
APUSH(AMAP,AVAL) ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME)
    ; AMAP IS FORMED FOR ARRAY ACCESS: AMAP(0) IS THE COUNT
    ; AND AMAP(N)=AVAL IS THE NTH AVAL
    ; ALSO HASH ACCESS AMAP(AVAL)=N WHERE N IS THE ASSIGNED ORDER OF THE
    ; MAP VALUE. INSTANCES OF THE MAP WILL USE $P(X,U,N)=AVAL TO PLACE
    ; THE ATTRIBUTE IN ITS RIGHT PLACE. THE ATTRIBUTE VALUE IS STORED
    ; SO THAT DIFFERENT MAPS CAN BE AUTOMATICALLY CROSSWALKED
    ;
    I '$D(@AMAP) D  ; IF THE MAP DOES NOT EXIST
    . S @AMAP@(0)=0 ; HAS ZERO ELEMENTS
    S @AMAP@(0)=@AMAP@(0)+1 ;INCREMENT ELEMENT COUNT
    S @AMAP@(@AMAP@(0))=AVAL ; ADD THE VALUE TO THE ARRAY
    S @AMAP@(AVAL)=@AMAP@(0) ; ADD THE VALUE TO THE HASH WITH ARRAY REF
    Q
    ;
ASETUP ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL
      I '$D(RIMBASE) S RIMBASE=$NA(^TMP("GPLRIM"))
      I '$D(@RIMBASE) S @RIMBASE=""
      I '$D(RIMTBL) S RIMTBL=$NA(^TMP("GPLRIM","RIMTBL","TABLE")) ; ATTR TABLE
      S ^TMP("GPLRIM","TABLES","RIMTBL")=RIMTBL ; TABLE OF TABLES
      Q
      ;
AINIT ; INITIALIZE ATTRIBUTE TABLE
      I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
      K @RIMTBL
      D APUSH(RIMTBL,"EXTRACTED")
      D APUSH(RIMTBL,"NOTEXTRACTED")
      D APUSH(RIMTBL,"HEADER")
      D APUSH(RIMTBL,"NOPCP")
      D APUSH(RIMTBL,"PCP")
      D APUSH(RIMTBL,"PROBLEMS")
      D APUSH(RIMTBL,"PROBCODE")
      D APUSH(RIMTBL,"PROBNOCODE")
      D APUSH(RIMTBL,"PROBDATE")
      D APUSH(RIMTBL,"PROBNODATE")
      D APUSH(RIMTBL,"VITALS")
      D APUSH(RIMTBL,"VITALSCODE")
      D APUSH(RIMTBL,"VITALSNOCODE")
      D APUSH(RIMTBL,"VITALSDATE")
      D APUSH(RIMTBL,"VITALSNODATE")
      D APUSH(RIMTBL,"MEDS")
      D APUSH(RIMTBL,"MEDSCODE")
      D APUSH(RIMTBL,"MEDSNOCODE")
      D APUSH(RIMTBL,"MEDSDATE")
      D APUSH(RIMTBL,"MEDSNODATE")
      Q
      ;
APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL
    ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING
    ; PTBL IS THE NAME OF A TABLE IN @RIMBASE@("TABLES") - "RIMTBL"=ALL VALUES
    ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL))
    I '$D(RIMBASE) D ASETUP ; FOR COMMANDLINE PROCESSING
    N USETBL
    I '$D(@RIMBASE@("TABLES",PTBL)) D  Q  ; NO TABLE
    . W "ERROR NO SUCH TABLE",!
    S USETBL=@RIMBASE@("TABLES",PTBL)
    S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL
    Q
GETPA(RTN,DFN,ISEC,IVAR) ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN
    ; EXAMPLE: D GETPA(.RT,2,"MEDS","MEDSSTATUSTEXT")
    ; RETURNS AN ARRAY RT OF VALUES OF MEDSTATUSTEXT FOR PATIENT 2 IN P2
    ; IN SECTION "MEDS"
    ; P1 IS THE IEN OF THE MED WITH THE VALUE IE 2^PENDING WOULD BE STATUS
    ; PENDING FOR MED 2 FOR PATIENT 2
    ; RT(0) IS THE COUNT OF HOW MANY IN THE ARRAY. NULL VALUES ARE
    ; RETURNED. RTN IS PASSED BY REFERENCE
    ;
    S RTN(0)=0 ; SET NULL DEFAULT RETURN VALUE
    I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES
    S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES
    I '$D(@ZVBASE@(DFN,ISEC,0)) D  Q ; NO VARIABLES IN SECTION
    . W "NO VARIABLES IN THIS SECTION FOR PATIENT ",DFN,!
    N ZZI,ZZS
    S ZZS=$NA(@ZVBASE@(DFN,ISEC)) ; SECTION VARIABLE ARRAY FOR THIS PATIENT
    ; ZWR @ZZS@(1)
    S RTN(0)=@ZZS@(0)
    F ZZI=1:1:RTN(0) D  ; FOR ALL PARTS OF THIS SECTION ( IE FOR ALL MEDS)
    . S $P(RTN(ZZI),"^",1)=ZZI ; INDEX FOR VARIABLE
    . S $P(RTN(ZZI),"^",2)=@ZZS@(ZZI,IVAR) ; THE VALUE OF THE VARIABLE
    Q
    ;
PATD(DFN,ISEC,IVAR) ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR
    ;
    N ZR
    D GETPA(.ZR,DFN,ISEC,IVAR)
    I $D(ZR(0)) D PARY^GPLXPATH("ZR")
    E  W "NOTHING RETURNED",!
    Q
    ;
CAGET(RTN,IATTR) ;
    ; GETPA LOOKS AT RIMTBL TO FIND PATIENTS WITH ATTRIBUTE IATTR
    ; IT DOES NOT SEARCH ALL PATIENTS, ONLY THE ONES WITH THE ATTRIBUTE
    ; IT RETURNS AN ARRAY OF THE VALUES OF VARIABLE IVAR IN SECTION ISEC
    Q
    ;
PCLST(LSTRTN,IATTR) ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR
    ;
    I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES
    N ZLST
    S LSTRTN(0)=0 ; DEFAULT RETURN NONE
    S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES
    S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS
    N ZNC  ; ZNC IS NUMBER OF CATEGORIES
    S ZNC=@ZCBASE@(0)
    I ZNC=0 Q ; NO CATEGORIES TO SEARCH
    N ZAP  ; ZAP IS THE PIECE INDEX OF THE ATTRIBUTE IN THE RIM ATTR TABLE
    S ZAP=@RIMBASE@("RIMTBL","TABLE",IATTR)
    N ZI,ZCATTBL,ZATBL,ZCNT,ZPAT
    F ZI=1:1:ZNC D  ; FOR ALL CATEGORIES
    . S ZATBL=@ZCBASE@(ZI) ; PULL OUT ATTR TBL FOR CAT
    . I $P(ZATBL,"^",ZAP)'="" D  ; CAT HAS ATTR
    . . S ZCATTBL=$P(@ZCBASE@(ZATBL),"^",1) ; NAME OF TBL
    . . M LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT
    S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS
    S ZPAT=0 ; START AT FIRST PATIENT IN LIST
    F  S ZPAT=$O(LSTRTN(ZPAT)) Q:ZPAT=""  D  ;
    . S ZCNT=ZCNT+1
    S LSTRTN(0)=ZCNT ; COUNT OF PATIENTS IN ARRAY
    Q
    ;
DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR
    ;
    N ZR
    D PCLST(.ZR,CATTR)
    I ZR(0)=0 D  Q  ;
    . W "NO PATIENTS RETURNED",!
    E  D  ;
    . D PARY^GPLXPATH("ZR") ; PRINT ARRAY
    . W "COUNT=",ZR(0),!
    Q
    ;