Changeset 636 for FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRM7M1.m

-              r628
+              r636
 PXRM7M1 ;SLC/JVS HL7 PUT MESSAGE IN 772 FILE; 06/01/2007  15:26
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRM7M1 ;SLC/JVS HL7 PUT MESSAGE IN 772 FILE; 03/21/2002 ;4/11/02  15:26
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;This routine will use the HL7 Package commands to gather the message
  ;into the file 772
 …
  S HLA("HLS",1)=PXRM77
  D GENERATE^HLMA(HL("EID"),"GM",1,.PXRM7R,.PXRM7ID,)
- D STORE^PXRM7API
  S ID=ZMID
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRM7XT.m

-              r628
+              r636
 PXRM7XT ;SLC/JVS HL7 EXTRACT FROM FILE; 06/01/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRM7XT ;SLC/JVS HL7 EXTRACT FROM FILE; 03/21/2002 ;4/11/02  15:26
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;This is the beginning of the extraction from the extract file
+ ;
 …
+ Q
 SPLIT ;SPLIT MESSAGES
+ ;
  N ORC2
  I LINE>100 D

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMAGE.m

-              r628
+              r636
+PXRMAGE ; SLC/PKR - Utilities for age calculations. ;10/07/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+PXRMAGE ; SLC/PKR - Utilities for age calculations. ;1/27/07  17:46
+ ;;2.0;CLINICAL REMINDERS;**4,7**;Feb 04, 2005;Build 14
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; 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 St, Fifth Floor, Boston, MA  02110-1301 USA
  ;===========================================
 AGE(DOB,DOD,DATE) ;Given a date of birth, date of death, and a date
 …
  ;return the age on the date of death. All dates should be in VA
  ;Fileman format.
  N CDATE
+ N CDATE,X,X1,X2,X3
  S CDATE=$S(DOD="":DATE,DOD'="":DOD)
+ Q (CDATE-DOB)\10000
+ S X=(CDATE-DOB)\10000 Q:X>1 X ; Begin VOE changes to support pediatrics
+ S X1=CDATE,X2=DOB
+ D ^%DTC S X3=X\365.25,X=$S(X3>2:X3,1:X_"D")
+ Q X ; End VOE changes to support pediatric ages
+ ;
  ;===========================================
 AGECHECK(AGE,MINAGE,MAXAGE) ;Given an AGE, MINimumAGE, and MAXimumAGE
+AGECHECK(PXRMAGE,MINAGE,MAXAGE) ;Given an AGE (with "Y", "M" or "D"), MINimumAGE, and MAXimumAGE
  ;return true if age lies within the range.
  ;Special values of NULL or 0 mean there are no limits.
+ ;
+ S MAXAGE=+MAXAGE
+ S MINAGE=+MINAGE
+ ; IHS/CIA/MGH - 5/12/2004 PATCH 1001 Changed to function call to calculate age
+ ; Two lines changed and one added ; for VOE too
+ ;S MAXAGE=+MAXAGE
+ ;S MINAGE=+MINAGE
+ ;
+ S MAXAGE=$$DECODE(MAXAGE) ; DECODE used in VOE Pediatric patients
+ S MINAGE=$$DECODE(MINAGE)
+ S AGEDAYS=$$DECODE(PXRMAGE)
+ ;
  ;See if too old.
  I (AGE>MAXAGE)&(MAXAGE>0) Q 0
+ I (AGEDAYS>MAXAGE)&(MAXAGE>0) Q 0
+ ;
  ;See if too young.
  I MINAGE=0 Q 1
  I AGE<MINAGE Q 0
+ I AGEDAYS<MINAGE Q 0
  Q 1
+ ;
+ ;===========================================
+DECODE(AGEVALUE) ; Put age from VADPT into format for reminders ; for VOE too
+ ; IHS/CIA/MGH - 5/12/2004 PATCH 1001 Added function to change age into days
+ N NUM,CODE,MULT
+ S NUM=+AGEVALUE,CODE=$P(AGEVALUE,NUM,2)
+ S MULT=1.0
+ I CODE="M" S MULT=30.42
+ I CODE=""!(CODE="Y") S MULT=365.25
+ Q +(MULT*NUM)
+ ;======================================================================
 FMTAGE(MINAGE,MAXAGE) ;Format the minimum age and maximum age for display.
  N STR
 …
 OVERLAP(NAR,MINA,MAXA) ;Check age ranges for overlap.  Return an error message
  ;if an overlap is found.
+ ;IHS/CIA/MGH Changes made to decode the ages into numeric results
  I NAR'>1 Q 0
  N IC,IN,JC,MAXI,MAXJ,MINI,MINJ,OVRLAP,TEXT
  S OVRLAP=0
  F IC=1:1:NAR-1 D
  . S MAXI=MAXA(IC)
+ . S MAXI=$$DECODE(MAXA(IC)) ; DECODE used in VOE Pediatric patients
  . I MAXI="" S MAXI=1000
  . S MINI=MINA(IC)
+ . S MINI=$$DECODE(MINA(IC))
  . I MINI="" S MINI=0
  . F JC=IC+1:1:NAR D
  .. S MAXJ=MAXA(JC)
+ .. S MAXJ=$$DECODE(MAXA(JC))
  .. I MAXJ="" S MAXJ=1000
  .. S MINJ=MINA(JC)
+ .. S MINJ=$$DECODE(MINA(JC))
  .. I MINJ="" S MINJ=0
  .. S IN=0
 …
  Q OVERLAP
+ ;
+ ;======================================================================
+RESTORE(SOURCE,INDEX,FREQ,MINAGE,MAXAGE) ;Restore FREQ, MINAGE, and
+ ;MAXAGE back to the original form.  From IHS for VOE
+ N IND,TEMP
+ I SOURCE="CFIND" D
+ . S IND=$O(^PXD(811.9,PXRMITEM,10,"B",INDEX,""))
+ . S TEMP=^PXD(811.9,PXRMITEM,10,IND,0)
+ ;
+ I SOURCE="HFIND" D
+ . S IND=$O(^PXD(811.9,PXRMITEM,6,"B",INDEX,""))
+ . S TEMP=^PXD(811.9,PXRMITEM,6,IND,0)
+ ;
+ I SOURCE="TFIND" D
+ . S IND=$O(^PXD(811.9,PXRMITEM,4,"B",INDEX,""))
+ . S TEMP=^PXD(811.9,PXRMITEM,4,IND,0)
+ ;
+ S MINAGE=$P(TEMP,U,2)
+ S MAXAGE=$P(TEMP,U,3)
+ S FREQ=$P(TEMP,U,4)
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMCDUE.m

-              r628
+              r636
 PXRMCDUE ;SLC/PKR - Custom date due calculation routines. ;09/05/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMCDUE ;SLC/PKR - Custom date due calculation routines. ;06/30/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;========================================================
 …
  . S FI=$P(TEMP,U,1)
  . S FREQ=$P(TEMP,U,2)
+ . S DATE=$S(FIEVAL(FI):+FIEVAL(FI,"DATE"),1:0)
+ . I DATE>0 S DATE=$$FULLDATE^PXRMDATE(DATE)
+ . S DATE=+$G(FIEVAL(FI,"DATE"))
  . S DLIST(IND)=$$NEWDATE^PXRMDATE(DATE,FREQ)
  S TEMP=$S(FUNCTION="MAX_DATE":$$MAXDATE(NARGS,.DLIST),FUNCTION="MIN_DATE":$$MINDATE(NARGS,.DLIST),1:0)
+ S TEMP=$S(FUNCTION="MAX_DATE":$$MAXDATE(NARGS,.DLIST),FUNCTION="MIN_DATE":$$MINDATE(NARGS,.DLIST))
  S DDUE=$P(TEMP,U,1)
  I DDUE=0 Q -1

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMCF.m

-              r628
+              r636
 PXRMCF ; SLC/PKR - Handle computed findings. ;07/25/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMCF ; SLC/PKR - Handle computed findings. ;12/15/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;=======================================================
 …
  D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
  S SDIR=$S(NOCC<0:+1,1:-1)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
  S TEST=PFINDPA(15)
  D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+ S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
+ ;Make sure NGET has the same sign as NOCC.
+ I NGET'=NOCC S NGET=NGET*($$ABS^XLFMTH(NOCC)/NOCC)
+ S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC)
  S TEMP=^PXRMD(811.4,ITEM,0)
  S TYPE=$P(TEMP,U,5)
 …
  S NOCCABS=$$ABS^XLFMTH(NOCC)
  D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
  S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCCABS)
+ S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCCABS)
  K ^TMP($J,TGLIST)
  S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(NGET,BDT,EDT,TGLIST,PARAM)"

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMCOND.m

-              r628
+              r636
 PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;06/01/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;11/01/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;============================================================
 …
  S CONDS=$G(FINDPA(3))
  S COND=$P(CONDS,U,1)
+ ;Even if there is no condition UCIFS could be used for status search.
+ S UCIFS=$P(CONDS,U,3)
+ S UCIFS=$S(COND="":0,1:$P(CONDS,U,3))
  I COND="" Q
  S CASESEN=$P(CONDS,U,2)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMCOPY.m

-              r628
+              r636
 PXRMCOPY ; SLC/PKR,PJH - Copy various reminder files. ;09/13/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMCOPY ; SLC/PKR,PJH - Copy various reminder files. ;05/11/2001
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;=====================================================
 …
  N DA,DIE,DIC,DIK,DIR,DIRUT,FDA,FIELDLEN,FILE
  N IENN,IENO,IENS,MSG,NAME,ORGNAME,X,Y
  S DIC=ROOT,DIC(0)="AEMQ",DIC("A")=PROMPT
+ S DIC=ROOT,DIC(0)="AEQ",DIC("A")=PROMPT
  W !
  D ^DIC
 …
+ ;
  ;=====================================================
-COPYLL ;Copy a location list.
- N PROMPT,ROOT,WHAT
- S WHAT="location list"
- S ROOT="^PXRMD(810.9,"
- S PROMPT="Select the reminder location list to copy: "
- D COPY(PROMPT,ROOT,WHAT)
+ Q
+ ;
- ;=====================================================
 COPYREM ;Copy a reminder definition.
  N PROMPT,ROOT,WHAT
  S WHAT="reminder"
  S ROOT="^PXD(811.9,"
  S PROMPT="Select the reminder definition to copy: "
+ S PROMPT="Select the reminder item to copy: "
  D COPY(PROMPT,ROOT,WHAT)
+ Q
 …
  S WHAT="taxonomy"
  S ROOT="^PXD(811.2,"
  S PROMPT="Select the reminder taxonomy to copy: "
+ S PROMPT="Select the taxonomy item to copy: "
  D COPY(PROMPT,ROOT,WHAT)
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDATA.m

-              r628
+              r636
 PXRMDATA ; SLC/PKR - Routines for getting data. ;04/02/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDATA ; SLC/PKR - Routines for getting data. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;===============================================
 …
  I FILENUM=100 D GETDATA^PXRMORDR(DAS,.FIEVT) Q
  I FILENUM=120.5 D GETDATA^PXRMVITL(DAS,.FIEVT) Q
  I FILENUM=601.84 D GETDATA^PXRMMH(DAS,.FIEVT) Q
+ I FILENUM=601.2 D GETDATA^PXRMMH(DAS,.FIEVT) Q
  I FILENUM=9000010 D GETDATA^PXRMVSIT(DAS,.FIEVT,1) Q
  I FILENUM=9000010.07 D GETDATA^PXRMVPOV(DAS,.FIEVT) Q
 …
  I ENODE="PSRX(" Q 52
  I ENODE="RAMIS(71," Q 70
  I ENODE="YTT(601.71," Q 601.84
+ I ENODE="YTT(601," Q 601.2
  Q 0
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDATE.m

-              r628
+              r636
 PXRMDATE ; SLC/PKR - Clinical Reminders date utilities. ;01/24/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDATE ; SLC/PKR - Clinical Reminders date utilities. ;06/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;==================================================
 …
  ;forms as well as T-NY to a FileMan date. Also understands LAD for
  ;Last Admission Date.
+ N %DT,ND,X,Y
+ ;Already a FileMan date?
+ S ND=+DATE
+ I (ND'<1000000),(ND'>9991231) Q DATE
+ N %DT,X,Y
  ;Check for a date FileMan understands.
  S X=DATE,%DT="ST"

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDBL3.m

-              r628
+              r636
 PXRMDBL3 ; SLC/PJH - Reminder Dialog Generation. (overflow) ;11/08/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMDBL3 ; SLC/PJH - Reminder Dialog Generation. (overflow) ;04/30/2001
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ; Called from PXRMDBL1
+ ;
  ;Set number range for site
+START ;
+ D SETSTART^PXRMCOPY("^PXRMD(801.41,")
+START D SETSTART^PXRMCOPY("^PXRMD(801.41,")
  ;Update dialog file for individual dialog items
  D UPDATE(.ARRAY,.WPTXT,"E")
 …
  N RNAME,TEST,YT S YT=""
  ;Convert ien to name
+ ;DBIA #5044
+ S YT("CODE")=$P($G(^YTT(601.71,IEN,0)),U)
+ S YT("CODE")=$P($G(^YTT(601,IEN,0)),U)
  ;Quit if no code found
  I YT("CODE")="" Q 0
+ I '$$OK^PXRMDLL(IEN) Q 0
+ ;Check if this is an allowable GUI test
+ I (YT("CODE")'="GAF"),($P($G(^YTT(601.6,IEN,0)),U,4)'="Y") Q 0
+ ;Get details of test
+ D SHOWALL^YTAPI3(.TEST,.YT)
  ;Check if valid
  ;I TEST(1)["[ERROR]" Q 0
+ I TEST(1)["[ERROR]" Q 0
+ ;
  S DNAME=FTYP_" "_YT("CODE")
 …
  ;Dialog item name, finding item and result
  S ARRAY(CNT)=DSHORT_U_U_RESN_U
- ;Commented out Result Group Patch 6 until a decision can be made
  ;Result group name
  ;S RNAME="PXRM "_YT("CODE")_" RESULT GROUP"
+ S RNAME="PXRM "_YT("CODE")_" RESULT GROUP"
  ;Result pointer
  ;S $P(ARRAY(CNT),U,7)=$O(^PXRMD(801.41,"B",RNAME,""))
+ S $P(ARRAY(CNT),U,7)=$O(^PXRMD(801.41,"B",RNAME,""))
  ;If aims exclude from p/n
  I YT("CODE")="AIMS" S $P(ARRAY(CNT),U,6)=1
 …
  ..;MH fields (exclude from P/N and results pointer)
  ..S:$P(INP(CNT),U,6) FDA(801.41,"?+1,",54)=$P(INP(CNT),U,6)
  ..;S:$P(INP(CNT),U,7) FDA(801.41,"?+1,",55)=$P(INP(CNT),U,7)
+ ..S:$P(INP(CNT),U,7) FDA(801.41,"?+1,",55)=$P(INP(CNT),U,7)
  .;Reminder dialog associated reminder/DISABLE
  .I DTYPE="R" D

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDEDT.m

-              r628
+              r636
 PXRMDEDT ; SLC/PJH - Edit PXRM reminder dialog. ;10/18/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDEDT ; SLC/PJH - Edit PXRM reminder dialog. ;07/28/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;Used by protocol PXRM SELECTION ADD/PXRM GENERAL ADD
 …
  ;Allows limited edit of national dialogs
  I $P($G(^PXRMD(801.41,DA,100)),U)="N" D
- .I TYP="T",+$P($G(^PXMRD(801.41,DA,100)),U,4)=0 Q
  .I $G(PXRMINST)=1,DUZ(0)="@" Q
  .S DR="[PXRM EDIT NATIONAL DIALOG]",DINUSE=1
 …
  .N DTYP
  .S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
- .;Allow limit edit of Result Elements that are not lock
- .I DTYP="T",+$P($G(^PXRMD(801.41,DA,100)),U,4)=0 Q
  .;Allow edit of findings but not component multiple on groups
  .I DTYP="G",$G(PXRMDIEN),DA'=PXRMDIEN Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDEV.m

-              r628
+              r636
 PXRMDEV ; SLC/PKR - This is a driver for testing Clinical Reminders.;01/24/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDEV ; SLC/PKR - This is a driver for testing Clinical Reminders.;05/04/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;==================================================
 …
  I DFN=-1 W !,"No patient selected!" Q
  S DIC=811.9,DIC("A")="Select Reminder: "
+ S DIC("S")="I $P(^PXD(811.9,Y,100),U,4)'[""L"""
  D ^DIC
  I $D(DIROUT)!$D(DIRUT) Q
 …
  S DFN=+$P(Y,U,1)
  S DIC=811.9,DIC("A")="Select Reminder: "
+ S DIC("S")="I $P(^PXD(811.9,Y,100),U,4)'[""L"""
  D ^DIC
  I $D(DIROUT)!$D(DIRUT) Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLG4.m

-              r628
+              r636
 PXRMDLG4 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;06/05/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDLG4 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;10/31/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
 WP(SUB,SUB1,WIDTH,SEQ,VALMCNT) ;Format WP text
 …
  W IORESET
  S VALMBCK="R",NATIONAL=0
+ ;Check if national reminder dialog
  I $P($G(^PXRMD(801.41,PXRMDIEN,100)),U)="N" S NATIONAL=1
  S LOCK=$P($G(^PXRMD(801.41,PXRMDIEN,100)),U,4)
+ ;Dissallow editing of national dialogs
  I NATIONAL,'($G(PXRMINST)=1)&(DUZ(0)="@"),$G(LOCK)'=1 D  Q
  .W !,"Elements may not be added to national reminder dialogs" H 2
 …
  .;Get ien of prompt/component
  .S DCIEN=$P($G(^PXRMD(801.41,DIEN,10,DSUB,0)),U,2) Q:'DCIEN
+ .;Ignore prompts and forced values
  .I "PF"[$P($G(^PXRMD(801.41,DCIEN,0)),U,4) Q
  .;Save line in workfile
 …
 DLINE(DIEN,LEV,DSEQ,NODE) ;Save individual component details
  N CNT,DBOX,DCAP,DDIS,DMULT,DSUPP,DSHOW,DTYP,DTXT
  N IC,RESNM,RESULT,RIEN,RNAME,RCNT
+ N IC,RESNM,RESULT,RIEN,RNAME
  ;Dialog name
  S DDATA=$G(^PXRMD(801.41,DIEN,0)),DNAM=$P(DDATA,U) Q:DNAM=""
 …
  S RNAME="",RIEN=$P($G(^PXRMD(801.41,DIEN,1)),U,3)
  I RIEN S RNAME=$P($G(^PXRMD(801.9,RIEN,0)),U)
+ ;Result Group
+ S RESULT=$P(DDATA,U,15)
+ I RESULT S RESNM=$P($G(^PXRMD(801.41,RESULT,0)),U)
+ ;
  ;Group fields
 …
  ..S TEMP=$J("",TAB)_"Resolution: "_RNAME
  ..S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP
- .;Result Group
- .I VIEW=4 D
- ..S RCNT=0 F  S RCNT=$O(^PXRMD(801.41,DIEN,51,RCNT)) Q:RCNT'>0  D
- ...S RESULT=$P($G(^PXRMD(801.41,DIEN,51,RCNT,0)),U)
- ...S RESNM=$P($G(^PXRMD(801.41,RESULT,0)),U) Q:RESNM=""
- ...S TEMP=$J("",TAB)_"Result Group: "_RESNM
- ...S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP
  .;Additional findings
  .D FADD(DIEN,TAB)
 …
 FDESC(FIEN) ;Finding description
  N FGLOB,FITEM,FNUM
+ ;Determine finding type
  S FGLOB=$P(FIEN,";",2) Q:FGLOB=""
  S FITEM=$P(FIEN,";") Q:FITEM=""

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLG5.m

-              r628
+              r636
 PXRMDLG5 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;11/08/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDLG5 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;05/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
-ALT(DIEN,LEV,DSEQ,NODE,VIEW,NLINE,CNT,ALTLEN) ;
- ;Display branching logic text in dialog summary view
- N DATA,DNAM,DTYP,IEN,TERM,TNAME,TSTAT,TEMP
- S DATA=$G(^PXRMD(801.41,DIEN,49))
- I '+$P(DATA,U)!($P($G(DATA),U,2)="") Q
- S TNAME=$P($G(^PXRMD(811.5,$P(DATA,U),0)),U)
- S TSTAT=$S($P(DATA,U,2)="1":"TRUE",1:"FALSE")
- I +$P(DATA,U,3)>0 D
- .S IEN=$P(DATA,U,3),DNAM=$P($G(^PXRMD(801.41,IEN,0)),U)
- .S DTYP=$S($P($G(^PXRMD(801.41,IEN,0)),U,4)="E":"Element",$P($G(^PXRMD(801.41,IEN,0)),U,4)="G":"Group")
- I $G(DNAM)="" S TEMP="Suppressed if Reminder Term "_TNAME_" evaluates as "_TSTAT
- I $G(DNAM)'="" S TEMP="Replaced by "_DNAM_" if Reminder Term "_TNAME_" evaluates as "_TSTAT
- D TEXT(.NLINES,CNT,ALTLEN,TEMP,NODE)
+ Q
+ ;
 ASK(YESNO,PIEN) ;Confirm
 …
  S VALMBCK="R"
+ Q
+ ;
+MSEL(NUM) ;
+ I NUM=4,'$$PATCH^XPDUTL("OR*3.0*243") D EN^DDIOL("THIS SELECTION IS NOT VALID, UNTIL CPRS 27 IS INSTALLED") Q 0
+ Q 1
+ ;
+ALT(DIEN,LEV,DSEQ,NODE,VIEW,NLINE,CNT,ALTLEN) ;
+ ;Display branching logic text in dialog summary view
+ N DATA,DNAM,DTYP,IEN,TERM,TNAME,TSTAT,TEMP
+ S DATA=$G(^PXRMD(801.41,DIEN,49))
+ I '+$P(DATA,U)!($P($G(DATA),U,2)="") Q
+ S TNAME=$P($G(^PXRMD(811.5,$P(DATA,U),0)),U)
+ S TSTAT=$S($P(DATA,U,2)="1":"TRUE",1:"FALSE")
+ I +$P(DATA,U,3)>0 D
+ .S IEN=$P(DATA,U,3),DNAM=$P($G(^PXRMD(801.41,IEN,0)),U)
+ .S DTYP=$S($P($G(^PXRMD(801.41,IEN,0)),U,4)="E":"Element",$P($G(^PXRMD(801.41,IEN,0)),U,4)="G":"Group")
+ I $G(DNAM)="" S TEMP="Suppressed if Reminder Term "_TNAME_" evaluates as "_TSTAT
+ I $G(DNAM)'="" S TEMP="Replaced by "_DNAM_" if Reminder Term "_TNAME_" evaluates as "_TSTAT
+ D TEXT(.NLINES,CNT,ALTLEN,TEMP,NODE)
+ Q
+ ;
+OTERM(DA) ;
+ K OTERM
+ S OTERM=$P($G(^PXRMD(801.41,DA,49)),U) Q
+ ;
+NTERM(DA,OTERM,NTERM) ;
+ I +OTERM=0 S OTERM=$P($G(DA),U)
+ I +NTERM=0 K OTERM Q 2
+ I +OTERM=0,+NTERM>0 K OTERM Q 1
+ I +OTERM'=+NTERM K OTERM Q 0
+ K OTERM
+ Q 1
+ ;
+TERMS(DA,X) ;
+ N TERM
+ S TERM=$P($G(^PXRMD(801.41,DA,49)),U)
+ I +TERM=0 D  Q 0
+ .W !,"Cannot set Reminder Term Status if the Reminder Term field is blank"
+ .H 2
+ I +TERM>0,$G(X)="" Q 2
+ Q 1
+ ;
 BHELP(VALUE) ;
 …
  I VALUE=4 D
  .;Patient Specific field
  .S HTEXT(1)="Enter either 1 for true or 0 for false. This value must be set to true"
+ .S HTEXT(1)="Enter either 1 for true or 0 for false. This value must be set totrue"
  .S HTEXT(2)="if item in this dialog will be using reminder term to either replace an item"
  .S HTEXT(3)="or to suppress an item."
 …
+ Q
+ ;
+TEXT(NLINES,CNT,ATLEN,TEMP,NODE) ;
+ N CNT1,NOUT,OUTPUT,WIDHT
+ S WIDTH=IOM-(2+(CNT+ATLEN))
+ S CNT1=1 D FORMATS^PXRMTEXT(1,WIDTH,TEMP,.NOUT,.OUTPUT)
+ I NOUT>0 F CNT1=1:1:NOUT D
+ .S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=$J("",2+(CNT+ATLEN))_OUTPUT(CNT1)
+ Q
+ ;
 INQ(DIEN) ;INQ Inquiry/Print option
+ ;
  ; Used by 801.41 print templates
  ; [PXRM REMINDER DIALOG]
 …
  K ^TMP(NODE,$J)
+ Q
+ ;
-MH(IEN) ;Allow IEN=109 (HX2) as a place holder for 601 entries that do not
- ;have a corresponding 601.71 entry.
- I IEN=109 Q 1
- I $G(PXRMINST)=1 Q 1
- N MAXNUM
- S MAXNUM=+$P($G(^PXRM(800,1,"MH")),U)
- I MAXNUM=0 S MAXNUM=25
- Q $$ONECR^YTQPXRM5(IEN,MAXNUM)
+ ;
-MHLICR(IEN) ;Called by input template PXRM EDIT ELEMENT. Preserve Y so template
- ;branching works.
- N Y
- ;DBIA #5042
- I $$RL^YTQPXRM3(IEN)="Y" D
- .W !,"This MH test requires a license."
- .W !,"The question text will not appear in the progress note.",!
- .H 1
+ Q
+ ;
-MSEL(NUM) ;
- I NUM=4,'$$PATCH^XPDUTL("OR*3.0*243") D EN^DDIOL("THIS SELECTION IS NOT VALID, UNTIL CPRS 27 IS INSTALLED") Q 0
- Q 1
+ ;
-MHREQHLP ;
- N TEXT
- S TEXT(1)="Select 0, ""Optional open and optional complete (partial complete possible)"","
- S TEXT(2)="if the user should be able to optionally select/open the MH test in the reminder dialog and optionally complete the MH test before the reminder dialog can be finished."
- S TEXT(3)=" "
- S TEXT(4)="Select 1, ""Required open and required complete before finish"","
- S TEXT(5)="if the user is required to select/open and complete the MH test in the reminder dialog before the reminder dialog can be finished."
- S TEXT(6)=" "
- S TEXT(7)="Select 2, ""Optional open and required complete or cancel before finish"","
- S TEXT(8)="if the user should be able to optionally select/open the MH test in the reminder dialog; however, if the user opens the MH test, then the user is required to complete or cancel the MH test before the reminder dialog can be finished."
- S TEXT(9)=" "
- S TEXT(10)="Note: Clicking the cancel button in the MH Test is considered the same as not opening the MH Test."
- S TEXT(11)="Also, Option 2, ""Optional open and required complete or cancel before finish"", only works with CPRS 27 and"
- S TEXT(12)="YS_MHA.dll. If Option 2 is selected and the user is using a pre-CPRS 27 version this option will be treated by CPRS as Option 1, ""Required open and required complete before finish""."
- D HELP^PXRMEUT(.TEXT)
+ Q
+ ;
-NTERM(DA,OTERM,NTERM) ;
- I +OTERM=0 S OTERM=$P($G(DA),U)
- I +NTERM=0 K OTERM Q 2
- I +OTERM=0,+NTERM>0 K OTERM Q 1
- I +OTERM'=+NTERM K OTERM Q 0
- K OTERM
- Q 1
+ ;
-OTERM(DA) ;
- K OTERM
- S OTERM=$P($G(^PXRMD(801.41,DA,49)),U)
+ Q
+ ;
-RESCHK(IEN) ;Called by input template PXRM EDIT ELEMENT. Preserve Y so template
- ;branching works.
- N CNT,FDA,MSG,RG,RGIEN,VALID,Y
- S CNT=0
- F  S CNT=$O(^PXRMD(801.41,IEN,51,CNT)) Q:CNT'>0  D
- .S RGIEN=$P($G(^PXRMD(801.41,IEN,51,CNT,0)),U) I +RGIEN'>0 Q
- .S RG=$P($G(^PXRMD(801.41,RGIEN,0)),U,1)
- .I RG="" Q
- .S VALID=$$RGLSCR(IEN,RG,RGIEN)
- .I VALID Q
- .W !,"Deleting the result group ",RG," from the element/group."
- .S FDA(801.41121,CNT_","_IEN_",",.01)="@"
- .D FILE^DIE("E","FDA","MSG")
- .S RGKILL=1
- .I $D(MSG) D AWRITE^PXRMUTIL("MSG")
+ Q
+ ;
-RSELEDIT(DA) ;
- N NODE,RESULT
- ;RESULT=0 EDIT NOTHING
- ;RESULT=1 EDIT INFORMATIONAL TEXT
- ;RESULT=2 EDIT EVERYTHING
- S RESULT=2
- I $G(PXRMINST)=1,DUZ(0)="@" Q RESULT
- S NODE=$G(^PXRMD(801.41,DA,100))
- I $P(NODE,U)="N" S RESULT=0
- I RESULT=0,+$P(NODE,U,4)=0 S RESULT=1
- Q RESULT
+ ;
-RGLSCR(DA,X,IEN) ;Input transform/screen for RESULT GROUP LIST
- I $G(PXRMINST)=1 Q 1
- I $G(PXRMEXCH)=1 Q 1
- N HELP,MHTEST,TEXT,VALID,Y
- S NMATCH=0
- S MHTEST=$O(^PXRMD(801.41,"B",X),-1)
- F  S MHTEST=$O(^PXRMD(801.41,"B",MHTEST)) Q:(NMATCH>1)!(MHTEST'[X)  S NMATCH=NMATCH+1
- ;If there is an exact match to the user's input turn help on.
- S HELP=$S($G(DIQUIET):0,NMATCH=1:1,1:0)
- S VALID=1
- ;Make sure the TYPE is a result group
- I '$D(^PXRMD(801.41,"TYPE","S",IEN)) D
- . I HELP S TEXT(1)="TYPE must be a result group."
- . S VALID=0
- ;Make sure the finding item for the element matches the
- ;MH Test assigned to the Result Group
- S MHTEST=+$P($G(^PXRMD(801.41,DA,1)),U,5) I MHTEST="" D
- . I HELP S TEXT(2)="The MH test is missing."
- . S VALID=0
- I +$P($G(^PXRMD(801.41,IEN,50)),U)'=MHTEST D
- . I HELP S TEXT(3)="The finding item does not match the MH Test assigned to the Result Group"
- . S VALID=0
- ;Make sure a scale has been defined.
- I +$P($G(^PXRMD(801.41,IEN,50)),U,2)'>0 D
- . I HELP S TEXT(4)="An MH Scale must be defined."
- . S VALID=0
- ;Make sure it is not disabled.
- I $P($G(^PXRMD(801.41,IEN,0)),U,3)'="" D
- . S VALID=0
- . I HELP D
- .. N EM,TYPE
- .. S TYPE=$P(^PXRMD(801.41,IEN,0),U,4)
- .. S TYPE=$$EXTERNAL^DILFD(801.41,4,"",TYPE,.EM)
- .. S TEXT(5)="The "_TYPE_" is disabled."
- I HELP,'VALID D EN^DDIOL(.TEXT)
- Q VALID
+ ;
-TERMS(DA,X) ;
- N TERM
- S TERM=$P($G(^PXRMD(801.41,DA,49)),U)
- I +TERM=0 D  Q 0
- .W !,"Cannot set Reminder Term Status if the Reminder Term field is blank"
- .H 2
- I +TERM>0,$G(X)="" Q 2
- Q 1
+ ;
-TEXT(NLINES,CNT,ATLEN,TEMP,NODE) ;
- N CNT1,NOUT,OUTPUT,WIDHT
- S WIDTH=IOM-(2+(CNT+ATLEN))
- S CNT1=1 D FORMATS^PXRMTEXT(1,WIDTH,TEMP,.NOUT,.OUTPUT)
- I NOUT>0 F CNT1=1:1:NOUT D
- .S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=$J("",2+(CNT+ATLEN))_OUTPUT(CNT1)
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLGZ.m

-              r628
+              r636
 PXRMDLGZ ; SLC/PJH - Link reminder to dialog. ;01/11/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDLGZ ; SLC/PJH - Link reminder to dialog. ;05/31/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;Called by option PXRM DIALOG/COMPONENT EDIT
 …
  .W $C(7),!,"A taxonomy cannot be entered as the finding item for a group"
  ;Only applies to MH
+ I $P(X,";",2)'="^YTT(601.71," Q 1
+ I $$OK^PXRMDLL($P(X,";")) Q 1
+ I $P(X,";",2)'="YTT(601," Q 1
+ ;GAF
+ I $P($G(^YTT(601,$P(X,";"),0)),U)="GAF" Q 1
+ ;Check if a VALID GUI test
+ I $P($G(^YTT(601.6,$P(X,";"),0)),U,4)="Y" Q 1
+ ;else
  W *7,!,"This test is not appropriate for the GUI",!
  Q 0

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLL.m

-              r628
+              r636
 PXRMDLL ;SLC/PJH - REMINDER DIALOG LOADER ;09/26/2007
  ;;2.0;CLINICAL REMINDERS;**10,6**;Feb 04, 2005;Build 123
+ ;;2.0;CLINICAL REMINDERS;**10**;Feb 04, 2005;Build 25
+ ;
 OK(DIEN) ;Check if mental health test is for GUI
+ I 'DIEN Q 0
+ Q $$MH^PXRMDLG5(DIEN)
+ I 'DFIEN Q 0
+ I $P($G(^YTT(601.6,DFIEN,0)),U,4)="Y" Q 1
+ I $P($G(^YTT(601,DFIEN,0)),U)="GAF" Q 1
+ Q 0
+ ;
 TXT ;Format text
 …
  .I $P($G(^PXRMD(801.41,DGIEN,2)),U,3) S DEXC=1
  .S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11) Q:"EG"'[DTYP
+ .S DMHEX=$P(DATA,U,14)
+ .S DRESL=$$RESGROUP^PXRMDLLB(DGIEN)
+ .;S DRESL=$P(DATA,U,15)
+ .S DMHEX=$P(DATA,U,14),DRESL=$P(DATA,U,15)
  .S DRES=$P($G(^PXRMD(801.41,DGIEN,1)),U,3)
  .;Done Elsewhere (historical)
 …
  S DARRAY("GMRD(120.51,")="VIT"
  S DARRAY("ORD(101.41,")="Q"
  S DARRAY("YTT(601.71,")="MH"
+ S DARRAY("YTT(601,")="MH"
  S DARRAY("ICD9(")="POV"
  S DARRAY("ICPT(")="CPT"
 …
  ..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DITEM,.DATA,.TERMSTAT)
  .S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11)
+ .S DMHEX=$P(DATA,U,14)
+ .S DRESL=$$RESGROUP^PXRMDLLB(DITEM)
+ .;S DRESL=$P(DATA,U,15)
+ .S DMHEX=$P(DATA,U,14),DRESL=$P(DATA,U,15)
  .K DTXT S SUB=0
  .F  S SUB=$O(^PXRMD(801.41,DITEM,25,SUB)) Q:'SUB  D

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLLA.m

-              r628
+              r636
 PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;11/08/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;07/29/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
 FREC(DFIEN,DFTYP) ;Build type 3 record
 …
  .;If mental health check if a GAF score and if MH test is required
  .I DPCE="MH",DFIEN D
+ ..;DBIA #5044
+ ..I $P($G(^YTT(601.71,DFIEN,0)),U)="GAF" S $P(ORY(OCNT),U,12)=1
+ ..I $P($G(^YTT(601,DFIEN,0)),U)="GAF" S $P(ORY(OCNT),U,12)=1
  ..;Check to see if the MH test is required
+ ..S $P(ORY(OCNT),U,13)=+$P($G(^PXRMD(801.41,DITEM,0)),U,18)
+ ..I $P(ORY(OCNT),U,13)=2,$$PATCH^XPDUTL("OR*3.0*243")=0 S $P(ORY(OCNT),U,13)=1
+ ..S $P(ORY(OCNT),U,13)=$S($P($G(^PXRMD(801.41,DITEM,0)),U,18)=1:1,1:0)
+ Q
+ ;
 …
  S DARRAY("GMRD(120.51,")="VIT"
  S DARRAY("ORD(101.41,")="Q"
  S DARRAY("YTT(601.71,")="MH"
+ S DARRAY("YTT(601,")="MH"
+ ;
  S DARRAY("ICD9(")="POV"

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLLB.m

-              r628
+              r636
 PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;05/01/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;07/29/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
 CODE(DFIEN,DFTYP,ARRAY) ;
 …
+ Q
+ ;
-RESGROUP(DIEN) ;
- N CNT,RESULT,TEMP
- S RESULT=""
- I $$PATCH^XPDUTL("OR*3.0*243")=0 D  Q RESULT
- .S RESULT=$P($G(^PXRMD(801.41,DIEN,51,1,0)),U) I RESULT="" Q
- .I $P($G(^PXRMD(801.41,RESULT,0)),U,3)'="" S RESULT="" Q
- S CNT=0 F  S CNT=$O(^PXRMD(801.41,DIEN,51,CNT)) Q:CNT'>0  D
- .S TEMP=$P($G(^PXRMD(801.41,DIEN,51,CNT,0)),U) I TEMP="" Q
- .I $P($G(^PXRMD(801.41,TEMP,0)),U,3)'="" S TEMP="" Q
- .S RESULT=$S(RESULT="":TEMP,1:RESULT_"~"_TEMP)
- Q RESULT
+ ;
 TERM(TERMIEN,DFN,IEN) ;
  ;this section is use to for the term evaluation

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLR.m

-              r628
+              r636
 PXRMDLR ;SLC/PJH - DIALOG RESULTS LOADER ;05/15/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMDLR ;SLC/PJH - DIALOG RESULTS LOADER ;06/09/2000
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;Build score related P/N text from score and result group
+ ;
  ;If not found
-START(ORY,RESULT,ORES) ;
  I '$G(RESULT) S ORY(1)="-1^no results for this test" Q
+ ;
  N ARRAY,ERROR,INSERT,OK,SCORE,SUB,YT,X
+ N ARRAY,ERROR,INSERT,OK,SCORE,SUB,YT
+ ;
- I RESULT["~" S RESULT=$P(RESULT,"~")
  S ERROR=0
+ ;
  ;Get score using API
  K ^TMP($J,"YSCOR")
+ S DFN=$G(ORES("DFN"))
  I ORES("CODE")'="DOM80" D  Q:ERROR
  .M YT=ORES
+ .F X=1:1:$L(YT("R1")) I $E(YT("R1"),X)'="X" S YT(X)=X_U_$E(YT("R1"),X)
+ .K YT("R1")
+ .D CHECKCR^YTQPXRM4(.ARRAY,.YT)
+ .S OK=0
+ .;D PREVIEW^YTAPI4(.ARRAY,.YT)
+ .I ^TMP($J,"YSCOR",1)'="[DATA]" S ORY(1)="-1^"_^TMP($J,"YSCOR",1)_^TMP($J,"YSCOD",2),ERROR=1 Q
+ .;I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2),ERROR=1 Q
+ .I $P($G(^TMP($J,"YSCOR",2)),"=",2)'="" S SCORE=$P($G(^TMP($J,"YSCOR",2)),"=",2),OK=1
+ .;S SUB=0,OK=0
+ .;F  S SUB=$O(ARRAY(SUB)) Q:'SUB  D  Q:OK
+ .;.I $P(ARRAY(SUB),U)="S1" S SCORE=$P(ARRAY(SUB),U,3),OK=1
+ .D PREVIEW^YTAPI4(.ARRAY,.YT)
+ .I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2),ERROR=1 Q
+ .S SUB=0,OK=0
+ .F  S SUB=$O(ARRAY(SUB)) Q:'SUB  D  Q:OK
+ ..I $P(ARRAY(SUB),U)="S1" S SCORE=$P(ARRAY(SUB),U,3),OK=1
  .I 'OK S ORY(1)="-1^[ERROR] no score returned",ERROR=1 Q
+ ;
 …
  .S SCORE=0
+ ;
- S DFN=$G(ORES("DFN"))
  S INSERT("SCORE")=SCORE
+ ;
 …
  .F CNT=2,3,4 S INSERT("SUM"_CNT)=SUM(CNT)
+ ;
-TEXT ;
- I RESULT["~" S RESULT=$P(RESULT,"~")
  ;Load dialog results into ORY array
  N DATA,DCON,DITEM,DSEQ,DSUB,DTYP,INS,SEP,TEXT
 …
+ Q
+ ;
-MHDLL(ORES,RESULT,SCORE,DFN) ;
- S INSERT("SCORE")=SCORE
- D TEXT
+ Q
 OUT(DATA) ;Display element details
  N DITEM S DITEM=$P(DATA,U,2) Q:'DITEM

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLR1.m

-              r628
+              r636
 PXRMDLR1 ; SLC/AGP - DIALOG ORPHAN REPORT. ; 11/16/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMDLR1 ; SLC/AGP - DIALOG ORPHAN REPORT. ; 02/04/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;=======================================================================
 …
  . W !,"  "_$G(NAME) S PCNT=PCNT+1 I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
  I FOUND=0 W !,"No empty dialog found"
  I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
+ I ($E(IOST)="C")&(IO=IO(0)) D
  . W !
  . S DIR(0)="E" D ^DIR K DIR
 …
  . .I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
  K ^TMP("PXRMDLR1",$J)
  I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
+ I ($E(IOST)="C")&(IO=IO(0)) D
  . W !
  . S DIR(0)="E" D ^DIR K DIR
 …
 PAGE(PCNT,PAGE) ;
  N DUOUT,DTOUT,DIROUT,DIR
  I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
+ I ($E(IOST)="C")&(IO=IO(0)) D
  .S DIR(0)="E"
  .W !
 …
  W:$D(IOF) @IOF
  S PAGE=PAGE+1,PCNT=0
  I ($E(IOST,1,2)="C-")&(IO=IO(0)) W @IOF D HEADER(.PCNT,PAGE,TITLE)
+ I $E(IOST)="C",IO=IO(0) W @IOF D HEADER(.PCNT,PAGE,TITLE)
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDNVA.m

-              r628
+              r636
 PXRMDNVA ; SLC/PKR - Handle non-VA med findings. ;03/14/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDNVA ; SLC/PKR - Handle non-VA med findings. ;05/24/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;===============================================
 …
  ;====================================================
 MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
  N DATE,JND,NOUT,TEMP,TEXTOUT
+ N JND,NOUT,TEMP,TEXTOUT
  S TEMP="Non-VA med: "_IFIEVAL("ORDERABLE ITEM")_" = "
  S TEMP=TEMP_"("_$$EDATE^PXRMDATE(IFIEVAL("START DATE"))
+ S DATE=IFIEVAL("DISCONTINUED DATE")
+ S DATE=$S(DATE="":"NONE",1:$$EDATE^PXRMDATE(DATE))
+ S TEMP=TEMP_" - "_$$EDATE^PXRMDATE(IFIEVAL("STOP DATE"))_")"
  D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
  F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDRGR.m

-              r628
+              r636
 PXRMDRGR ; SLC/PKR - Handle groups of drug findings. ;06/20/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDRGR ; SLC/PKR - Handle groups of drug findings. ;06/12/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;Groups are drug classes or VA Generic.
  ;==================================================
 …
  .. S IND=0
  .. F  S IND=+$O(FIEVT(IND)) Q:IND=0  D
- ...;Make sure this is not already on the list
- ... I $$ONLIST(.FIEVTL,IND,.FIEVT) Q
  ... S NFOUND=NFOUND+1,FIEVTL(NFOUND,"DISPENSE DRUG")=DRUGIEN
  ... M FIEVTL(NFOUND)=FIEVT(IND)
 …
+ Q
+ ;
- ;==================================================
-ONLIST(FIEVTL,IND,FIEVT) ;Return true if FIEVT(IND) is already on
- ;FIEVTL.
- N JND,ONLIST
- S (JND,ONLIST)=0
- F  S JND=$O(FIEVTL(JND)) Q:(ONLIST)!(JND="")  D
- . I FIEVTL(JND,"FILE NUMBER")'=FIEVT(IND,"FILE NUMBER") Q
- . I FIEVTL(JND,"DAS")'=FIEVT(IND,"DAS") Q
- . S ONLIST=1
- Q ONLIST
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDRUG.m

-              r628
+              r636
 PXRMDRUG ; SLC/PKR - Handle drug findings. ;04/23/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDRUG ; SLC/PKR - Handle drug findings. ;06/08/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;===============================================
 …
  ;===============================================
 EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate drug terms.
  N DATEORDR,DRUGIEN,DTERM,DTFIEVAL,IND,JND,NOINDEX,PFINDPA,POI
+ N DATEORDR,DRUGIEN,DTERM,DTFIEVAL,IND,NOINDEX,PFINDPA,POI
  N RXTYL,TEMP,TFINDING,TFINDPA
  N DATEORDR,NOCC,SDIR
 …
  .. D DORDER^PXRMTERM(.DTFIEVAL,.DATEORDR)
  .. D COPY^PXRMTERM(NOCC,SDIR,.DTFIEVAL,.DATEORDR,TFINDING,.TFIEVAL)
+ ..;Save the dispense drug
+ .. S JND=0
+ .. F  S JND=+$O(TFIEVAL(TFINDING,JND)) Q:JND=0  S TFIEVAL(TFINDING,JND,"DISPENSE DRUG")=DRUGIEN
+ .. I TFIEVAL(TFINDING) S TFIEVAL(TFINDING,"DISPENSE DRUG")=DRUGIEN
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEDIT.m

-              r628
+              r636
 PXRMEDIT ; SLC/PKR - Clinical Reminder edit driver. ;06/04/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEDIT ; SLC/PKR - Clinical Reminder edit driver. ;05/18/2000
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
 EDIT(ROOT,IENN) ;Call the appropriate edit routine.
- ;Reminder location list
- I ROOT="^PXRMD(810.9," D EDIT^PXRMLLED(ROOT,IENN) Q
+ ;
  ;Taxonomy
  I ROOT="^PXD(811.2," D EDIT^PXRMTEDT(ROOT,IENN) Q
 …
  I ROOT="^PXRMD(811.5," D EDIT^PXRMTMED(ROOT,IENN) Q
+ ;
  ;Reminder definition
+ ;Reminder
  I ROOT="^PXD(811.9," D
  .;Build list of finding types for finding edit

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMENOD.m

-              r628
+              r636
 PXRMENOD ; SLC/PKR - Clinical Reminders "E" node routines. ;12/13/2006
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMENOD ; SLC/PKR - Clinical Reminders "E" node routines. ;04/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;========================================================
 …
  ;Do not execute as part of a verify fields.
  I $G(DIUTIL)="VERIFY FIELDS" Q
  N DAS,GLOBAL,IEN,NAME
+ N DAS,GLOBAL,IEN
  S IEN=$P(X,";",1)
  S GLOBAL=$P(X,";",2)
 …
  S DAS=IEN
  I DAS="" Q
+ S NAME=""
+ I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA)=NAME
+ I FILENUM=811.9 S ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)=NAME
+ I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA)=""
+ I FILENUM=811.9 S ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)=""
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEPM.m

-              r628
+              r636
 PXRMEPM ; SLC/PKR/PJH - Extract Definition Management ;07/17/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMEPM ; SLC/PKR/PJH - Extract Definition Management ;06/21/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;Main entry point for PXRM EXTRACT DEFINITIONS
 …
  K ^TMP("PXRMEPM",$J)
  N IEN,IND,PLIST
+ D LIST^PXRMETM("PXRMEPM",.VALMCNT)
+ D LIST^PXRMETM(.PLIST,.IEN)
+ M ^TMP("PXRMEPM",$J)=PLIST
+ S VALMCNT=PLIST("VALMCNT")
+ F IND=1:1:VALMCNT D
+ .S ^TMP("PXRMEPM",$J,"IDX",IND,IND)=IEN(IND)
+ Q
+ ;
 …
  .W $C(7),!,"Only one item number allowed." H 2
  .S VALMBCK="R"
  I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
  .W $C(7),!,SEL_" is not a valid item number." H 2
  .S VALMBCK="R"
+ ;
  ;Get the list ien.
  S IEN=^TMP("PXRMEPM",$J,"SEL",SEL)
+ S IEN=^TMP("PXRMEPM",$J,"IDX",SEL,SEL)
  ;Display/Edit Extract Definition
  D START^PXRMEPED(IEN)
 …
+ ;
 EPADD ;Add Rule Option
+ ;
  ;Reset Screen Mode
  W IORESET
 …
  ;Rebuild Workfile
  D BLDLIST
+ ;
  S VALMBCK="R"
+ Q
 …
  F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
  .;Get the ien.
  .S LRIEN=^TMP("PXRMEPM",$J,"SEL",IND)
+ .S LRIEN=^TMP("PXRMEPM",$J,"IDX",IND,IND)
  .D START^PXRMEPED(LRIEN)
  D BLDLIST

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETCO.m

-              r628
+              r636
 PXRMETCO ; SLC/PJH - QUERI Extract Compliance Report ;03/27/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMETCO ; SLC/PJH - QUERI Extract Compliance Report ;01/19/2005
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;
 …
  S LIST=NAME_" REPORT "_DATES
  ;Process (single) Denominator rule into patient list
  N INDP,INTP,SEQ,SUB,SUFFIX
+ N SEQ,SUB,SUFFIX
  S SEQ=""
  F  S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ  D
 …
  .S SUFFIX=$P(DATA,U,3)
  .I SUFFIX="" S SUFFIX="DENOMINATOR "_SEQ
- .S INDP=+$P(DATA,U,4)
- .S INTP=+$P(DATA,U,5)
  .;Create new patient list
  .S PXRMLIST=$$CRLST^PXRMRUL1(LIST_" "_SUFFIX) Q:'PXRMLIST
  .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,INDP,INTP)
+ .S PXRMLIST=$$CRLST^PXRMRULE(LIST_" "_SUFFIX) Q:'PXRMLIST
+ .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,"","")
  .;Clear ^TMP lists created for rule
  .D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
 …
  W !,"Queue the Clinical Reminders MST synchronization."
  S DIR("A",1)="Enter the date and time you want the job to start."
+ S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
+ S DIR("A")="Start the task at: "
+ S DIR("A")="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")_" "
  S DIR(0)="DAU"_U_MINDT_"::RSX"
  D ^DIR

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETH.m

-              r628
+              r636
 PXRMETH ; SLC/PJH - Reminder Extract History ;10/11/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMETH ; SLC/PJH - Reminder Extract History ;08/15/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;Main entry point for PXRM EXTRACT HISTORY
+START(EDIEN) ;
+ ;EDIEN is the extract definition IEN.
+START(IEN) ;
  N VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
  ;Details of last run
  N DATA,NPERIOD,NSDATE,NTAS,PXRMVIEW
  S DATA=$G(^PXRM(810.2,EDIEN,0))
+ S DATA=$G(^PXRM(810.2,IEN,0))
  S NPERIOD=$P(DATA,U,6),NSDATE=$P(DATA,U,7)
  ;Default view is in date created order
 …
+ Q
+ ;
-DELETE ;Delete an extract, called by protocol PXRM EXTRACT SUMMARY DELETE.
- N CLASS,IEN,IENLIST,IND
- S IENLIST=$$LMSEL
- F IND=1:1:$L(IENLIST,U) D
- .S IEN=$P(IENLIST,U,IND)
- .D DELETE^PXRMETXU(IEN)
- ;Rebuild workfile
- D BLDLIST^PXRMETH1(EDIEN)
- ;Refresh
- S VALMBCK="R"
+ Q
+ ;
 ENTRY ;Entry code
  D BLDLIST^PXRMETH1(EDIEN),XQORM
+ D BLDLIST^PXRMETH1(IEN),XQORM
+ Q
+ ;
 …
+ Q
+ ;
+EXTRACT(EDIEN) ;Run Extract/Transmission
+HDR ; Header code
+ N VIEW
+ S VIEW=$S(PXRMVIEW="D":"Creation Date Order",1:"Extract Period Order")
+ S VALMHDR(2)="          Extract Name: "_$P($G(^PXRM(810.2,IEN,0)),U)
+ S VALMHDR(3)="   Next Extract Period: "_NPERIOD
+ S VALMHDR(4)="      Scheduled to Run: "_NSDATE
+ S VALMHDR(4)=$$LJ^XLFSTR(VALMHDR(4),45)_"    View: "_VIEW
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+HLP ;Help code
+ N ORU,ORUPRMT,SUB,XQORM
+ S SUB="PXRMETHH"
+ D EN^VALM("PXRM EXTRACT HELP")
+ Q
+ ;
+INIT ;Init
+ S VALMCNT=0
+ Q
+ ;
+PEXIT ;PXRM EXCH MENU protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ D XQORM
+ Q
+ ;
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT HISTORY SELECT ENTRY",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Item: "
+ Q
+ ;
+XSEL ;PXRM EXTRACT HISTORY SELECT ENTRY validation
+ N SEL,PXRMSIEN
+ S SEL=$P(XQORNOD(0),"=",2)
+ ;Remove trailing ,
+ I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
+ ;Invalid selection
+ I SEL["," D  Q
+ .W $C(7),!,"Only one item number allowed." H 2
+ .S VALMBCK="R"
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
+ .W $C(7),!,SEL_" is not a valid item number." H 2
+ .S VALMBCK="R"
+ ;
+ ;Get the list ien.
+ S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",SEL,SEL)
+ ;
+ ;Full screen mode
+ D FULL^VALM1
+ ;
+ ;Options
+ N X,Y,DIR,OPTION K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="SBM"_U_"ES:Extract Summary;"
+ S DIR(0)=DIR(0)_"MT:Manual Transmission;"
+ S DIR(0)=DIR(0)_"TH:Transmission History;"
+ S DIR("A")="Select Action"
+ S DIR("B")="ES"
+ S DIR("?")="Select from the codes displayed. For detailed help type ??"
+ S DIR("??")=U_"D HELP^PXRMETH1(1)"
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
+ S OPTION=Y
+ ;
+ ;Display Extract Summary
+ I OPTION="ES" D
+ .D START^PXRMETT(PXRMSIEN)
+ ;
+ ;Transmission option
+ I OPTION="MT" D
+ .N ANS,DUOUT,DTOUT,RTN,TEXT
+ .I $P($G(^PXRMXT(810.3,PXRMSIEN,100)),U)'="N" D  Q
+ ..W !,"Local extracts cannot be transmitted to AAC" H 2 Q
+ .S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
+ .S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
+ .I ANS D TRANS^PXRMETX(PXRMSIEN)
+ ;
+ ;Transmission History
+ I OPTION="TH" D
+ .D START^PXRMETHL(PXRMSIEN)
+ ;
+ S VALMBCK="R"
+ Q
+ ;
+EXTRACT(IEN) ;Run Extract/Transmission
+ ;
  ;Reset screen mode
  W IORESET
 …
  N ANS,DATA,DUOUT,DTOUT,EDATE,EXSUMPUG,FREQ,MODE
  N NAME,NAT,NEXT,PLISTPUG,RTN,REPL,STATUS,SNEXT,TEXT,XMIT
  S DATA=$G(^PXRM(810.2,EDIEN,0))
  S NAT=$P($G(^PXRM(810.2,EDIEN,100)),U)
+ S DATA=$G(^PXRM(810.2,IEN,0))
+ S NAT=$P($G(^PXRM(810.2,IEN,100)),U)
  ;Determine Extract Name and Frequency
  S NAME=$P(DATA,U),FREQ=$P(DATA,U,3),NEXT=$P(DATA,U,6),RTN="PXRMETX"
 …
  N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
  S ZTDESC="Reminder Extract "_NAME
  S ZTRTN="RUN^PXRMETX(EDIEN,NEXT,MODE,EXSUMPUG)"
  S ZTSAVE("EDIEN")=""
+ S ZTRTN="RUN^PXRMETX(IEN,NEXT,MODE,EXSUMPUG)"
+ S ZTSAVE("IEN")=""
  S ZTSAVE("MODE")=""
  S ZTSAVE("NEXT")=""
 …
  D ^%ZTLOAD
  W !,"Task number ",ZTSK," queued." H 2
+ ;
  S VALMBCK="Q"
+ Q
+ ;
-HDR ; Header code
- N VIEW
- S VIEW=$S(PXRMVIEW="D":"Creation Date Order",1:"Extract Period Order")
- S VALMHDR(2)="          Extract Name: "_$P($G(^PXRM(810.2,EDIEN,0)),U)
- S VALMHDR(3)="   Next Extract Period: "_NPERIOD
- S VALMHDR(4)="      Scheduled to Run: "_$$FMTE^XLFDT(NSDATE,"5Z")
- S VALMHDR(4)=$$LJ^XLFSTR(VALMHDR(4),45)_"    View: "_VIEW
- S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
-HLP ;Help code
- N ORU,ORUPRMT,SUB,XQORM
- S SUB="PXRMETHH"
- D EN^VALM("PXRM EXTRACT HELP")
+ Q
+ ;
-INIT ;Init
- S VALMCNT=0
+ Q
+ ;
-LMSEL() ;Return selection list
- N IENLIST,IND,VALMY,XIEN
- D EN^VALM2(XQORNOD(0))
- ;If there is no list quit.
- I '$D(VALMY) Q ""
- S PXRMDONE=0,IENLIST=""
- S IND=""
- F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
- .;Get the ien.
- .S XIEN=^TMP("PXRMETH",$J,"SEL",IND)
- .S IENLIST=$S(IENLIST'="":IENLIST_U_XIEN,1:XIEN)
- Q IENLIST
+ ;
-PEXIT ;PXRM EXCH MENU protocol exit code
- S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
- D XQORM
+ Q
+ ;
 SELECT(FREQ,SEL) ;Select extract period
+ ;
  N BDATE,EDATE,DA,DIE,DIK,DIR,DR,FDATE,VALID,X
  ;Get the new name.
 …
+ Q
+ ;
+TLIST ;Extract summary display
+ N IEN,IENLIST,IND
+ S IENLIST=$$LMSEL
+ F IND=1:1:$L(IENLIST,U) D
+ .S IEN=$P(IENLIST,U,IND)
+ .D START^PXRMETT(IEN)
+ .S VALMBCK="R"
+TLIST ;Extract Totals
+ N IND,PXRMSIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;PXRMDONE is newed in PXRMLPM
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
+ .D START^PXRMETT(PXRMSIEN)
+ ;
  S VALMBCK="R"
+ Q
+ ;
 TRANS ;Run Transmission
+ N IEN,IENLIST,IND
+ S IENLIST=$$LMSEL
+ F IND=1:1:$L(IENLIST,U) D
+ .S IEN=$P(IENLIST,U,IND)
+ .I $P($G(^PXRMXT(810.3,IEN,100)),U)'="N" D  Q
+ ..W !,"Local extracts cannot be transmitted to AAC." H 2
+ N IND,PXRMXIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S PXRMXIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
+ .I $P($G(^PXRMXT(810.3,PXRMXIEN,100)),U)'="N" D  Q
+ ..W !,"Local extracts cannot be transmitted to AAC." H 1
  .;Transmit extract summary
  .N ANS,DUOUT,DTOUT,RTN,TEXT
  .S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
  .S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
  .I ANS D TRANS^PXRMETX(IEN)
+ .I ANS D TRANS^PXRMETX(PXRMXIEN)
+ ;
  ;Rebuild workfile
  D BLDLIST^PXRMETH1(EDIEN)
+ D BLDLIST^PXRMETH1(IEN)
  ;Refresh
  S VALMBCK="R"
 …
+ ;
 TRHIST ;Transmission History
+ N IEN,IENLIST,IND
+ S IENLIST=$$LMSEL
+ F IND=1:1:$L(IENLIST,U) D
+ .S IEN=$P(IENLIST,U,IND)
+ .D START^PXRMETHL(IEN)
+ N IND,PXRMSIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;PXRMDONE is newed in PXRMLPM
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
+ .D START^PXRMETHL(PXRMSIEN)
+ ;
  S VALMBCK="R"
+ Q
 …
+ ;
 VIEW ;Select view
+ ;
  W IORESET
+ S VALMBCK="R"
+ ;
+ S VALMBCK="R"
+ ;
  N X,Y,CODE,DIR
  K DIROUT,DIRUT,DTOUT,DUOUT
 …
+ ;
  ;Rebuild Workfile
  D BLDLIST^PXRMETH1(EDIEN),HDR
+ D BLDLIST^PXRMETH1(IEN),HDR
+ Q
+ ;
 …
  W !!,"WARNING -This period is not complete until "_FDATE
+ Q
-XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT HISTORY SELECT ENTRY",0))_U_"1:"_VALMCNT
- S XQORM("A")="Select Item: "
+ Q
+ ;
-XSEL ;PXRM EXTRACT HISTORY SELECT ENTRY validation
- N SEL,PXRMSIEN
- S SEL=$P(XQORNOD(0),"=",2)
- ;Remove trailing ,
- I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
- ;Invalid selection
- I SEL["," D  Q
- .W $C(7),!,"Only one item number allowed." H 2
- .S VALMBCK="R"
- I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
- .W $C(7),!,SEL_" is not a valid item number." H 2
- .S VALMBCK="R"
+ ;
- ;Get the list ien.
- ;S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",SEL,SEL)
- S PXRMSIEN=^TMP("PXRMETH",$J,"SEL",SEL)
+ ;
- ;Full screen mode
- D FULL^VALM1
+ ;
- ;Options
- N X,Y,DIR,OPTION K DIROUT,DIRUT,DTOUT,DUOUT
- S DIR(0)="SBM"_U_"DE:Delete Extract;"
- S DIR(0)=DIR(0)_"ES:Extract Summary;"
- S DIR(0)=DIR(0)_"MT:Manual Transmission;"
- S DIR(0)=DIR(0)_"TH:Transmission History;"
- S DIR("A")="Select Action"
- S DIR("B")="ES"
- S DIR("?")="Select from the codes displayed. For detailed help type ??"
- S DIR("??")=U_"D HELP^PXRMETH1(1)"
- D ^DIR K DIR
- I $D(DIROUT) S DTOUT=1
- I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
- S OPTION=Y
+ ;
- ;Delete an extract
- I OPTION="DE" D
- .D DELETE^PXRMETXU(PXRMSIEN)
- .;Rebuild workfile
- .D BLDLIST^PXRMETH1(PXRMSIEN)
- .;Refresh
- .S VALMBCK="R"
+ ;
- ;Display Extract Summary
- I OPTION="ES" D START^PXRMETT(PXRMSIEN)
+ ;
- ;Transmission option
- I OPTION="MT" D
- .N ANS,DUOUT,DTOUT,RTN,TEXT
- .I $P($G(^PXRMXT(810.3,PXRMSIEN,100)),U)'="N" D  Q
- ..W !,"Local extracts cannot be transmitted to AAC" H 2 Q
- .S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
- .S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
- .I ANS D TRANS^PXRMETX(PXRMSIEN)
+ ;
- ;Transmission History
- I OPTION="TH" D START^PXRMETHL(PXRMSIEN)
+ ;
- S VALMBCK="R"
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETH1.m

-              r628
+              r636
 PXRMETH1 ; SLC/PJH - Reminder Extract History ;09/07/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMETH1 ; SLC/PJH - Reminder Extract History ;07/24/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+BLDLIST(EDIEN) ;Build workfile
+ ;EDIEN is the extract definition IEN.
+ N IND,FMTSTR,PLIST
+BLDLIST(IEN) ;Build workfile
+ N IND,PLIST
  K ^TMP("PXRMETH",$J)
- S FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLL")
  ;Build list of extract summaries in period order
  I PXRMVIEW="P" D LIST1(EDIEN,"PXRMETH",FMTSTR)
+ I PXRMVIEW="P" D LIST1(.PLIST,.IEN)
  ;Build list of extract summaries in date order
+ I PXRMVIEW="D" D LIST2(EDIEN,"PXRMETH",FMTSTR)
+ Q
+ ;
+FMT(NUMBER,NAME,EDATE,XDATE,AUTO,FMTSTR,NL,OUTPUT) ;Format
+ N TAUTO,TDATE,TEMP,TNAME,TSOURCE
+ S TEMP=NUMBER_U_NAME_U
+ S TDATE=$$FMTE^XLFDT(EDATE,"5Z")
+ S TEMP=TEMP_$$LJ^XLFSTR(TDATE,20," ")
+ S TDATE=XDATE I TDATE S TDATE=$$FMTE^XLFDT(TDATE,"5Z")
+ S TEMP=TEMP_" "_$$LJ^XLFSTR(TDATE,22," ")
+ S TAUTO=AUTO
+ S TEMP=TEMP_TAUTO
+ D COLFMT^PXRMTEXT(FMTSTR,TEMP," ",.NL,.OUTPUT)
+ I PXRMVIEW="D" D LIST2(.PLIST,.IEN)
+ ;Move into list array
+ M ^TMP("PXRMETH",$J)=PLIST
+ S VALMCNT=PLIST("VALMCNT")
+ ;Allow selection by item
+ F IND=1:1:VALMCNT D
+ .S ^TMP("PXRMETH",$J,"IDX",IND,IND)=IEN(IND)
+ Q
+ ;
 …
  N HTEXT
  I CALL=1 D
+ .S HTEXT(1)="Select DE to delete an extract.\\"
+ .S HTEXT(2)="Select ES to view the details of an extract or run a compliance"
+ .S HTEXT(3)="report for the extract.\\Select MT to transmit extract details to the AAC.\\"
+ .S HTEXT(4)="Select TH to view the transmission history for an extract."
+ .S HTEXT(1)="Select ES to view the details of an extract or run a compliance"
+ .S HTEXT(2)="report for the extract. Select MT to transmit extract details to the AAC."
+ .S HTEXT(3)="Select TH to view the transmission history for an extract."
+ ;
  I CALL=3 D
 …
+ Q
+ ;
+LIST1(EDIEN,NODE,FMTSTR) ;Build a list of extract summaries for a parameter.
+ N AUTO,EDATE,HL7ID,HL7SUB,IND,JND,NAME,NL,NUM,OUTPUT
+ N PERIOD,STR,XDATE,YEAR
+LIST1(LIST,IEN) ;Build a list of extract summaries for a parameter.
+ N AUTO,EDATE,HL7ID,HL7SUB,IND,NAME,PERIOD,XDATE,YEAR
  ;Build list of extract summaries in reverse date order.
  S YEAR="9999",(NUM,VALMCNT)=0
  F  S YEAR=$O(^PXRMXT(810.3,"D",EDIEN,YEAR),-1) Q:YEAR=""  D
+ S YEAR="9999",VALMCNT=0
+ F  S YEAR=$O(^PXRMXT(810.3,"D",IEN,YEAR),-1) Q:YEAR=""  D
  .S PERIOD="99"
  .F  S PERIOD=$O(^PXRMXT(810.3,"D",EDIEN,YEAR,PERIOD),-1) Q:PERIOD=""  D
+ .F  S PERIOD=$O(^PXRMXT(810.3,"D",IEN,YEAR,PERIOD),-1) Q:PERIOD=""  D
  ..S IND=""
  ..F  S IND=$O(^PXRMXT(810.3,"D",EDIEN,YEAR,PERIOD,IND),-1) Q:IND=""  D
+ ..F  S IND=$O(^PXRMXT(810.3,"D",IEN,YEAR,PERIOD,IND),-1) Q:IND=""  D
  ...S NAME=$P($G(^PXRMXT(810.3,IND,0)),U)
  ...S EDATE=$P($G(^PXRMXT(810.3,IND,0)),U,6)
 …
  ...I HL7SUB S XDATE=$P($G(^PXRMXT(810.3,IND,5,HL7SUB,0)),U,2)
  ...I 'XDATE S XDATE="Not Transmitted"
+ ...S NUM=NUM+1
+ ...D FMT(NUM,NAME,EDATE,XDATE,AUTO,FMTSTR,.NL,.OUTPUT)
+ ...F JND=1:1:NL D
+ ....S VALMCNT=VALMCNT+1,^TMP(NODE,$J,VALMCNT,0)=OUTPUT(JND)
+ ....S ^TMP(NODE,$J,"IDX",VALMCNT,NUM)=""
+ ....S ^TMP(NODE,$J,"SEL",NUM)=IND
+ ...S VALMCNT=VALMCNT+1
+ ...S LIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,EDATE,XDATE,AUTO)
+ ...S IEN(VALMCNT)=IND
+ S LIST("VALMCNT")=VALMCNT
+ Q
+ ;
+LIST2(EDIEN,NODE,FMTSTR) ;Build a list of extract summaries for a parameter.
+ N AUTO,EDATE,HL7ID,HL7SUB,IND,JND,NAME,NL,NUM,OUTPUT
+ N PERIOD,STR,XDATE,YEAR
+LIST2(LIST,IEN) ;Build a list of extract summaries for a parameter.
+ N AUTO,EDATE,HL7ID,HL7SUB,IND,NAME,PERIOD,XDATE,YEAR
  ;Build list of extract summaries in reverse date order.
  S EDATE="",(NUM,VALMCNT)=0
  F  S EDATE=$O(^PXRMXT(810.3,"C",EDIEN,EDATE),-1) Q:'EDATE  D
+ S EDATE="",VALMCNT=0
+ F  S EDATE=$O(^PXRMXT(810.3,"C",IEN,EDATE),-1) Q:'EDATE  D
  .S IND=""
  .F  S IND=$O(^PXRMXT(810.3,"C",EDIEN,EDATE,IND)) Q:'IND  D
  ..S NAME=$P($G(^PXRMXT(810.3,IND,0)),U,1)
+ .F  S IND=$O(^PXRMXT(810.3,"C",IEN,EDATE,IND)) Q:'IND  D
+ ..S NAME=$P($G(^PXRMXT(810.3,IND,0)),U)
  ..S AUTO=$P($G(^PXRMXT(810.3,IND,4)),U,5)
  ..S AUTO=$S(AUTO="A":"Y",1:"N")
 …
  ..I HL7SUB S XDATE=$P($G(^PXRMXT(810.3,IND,5,HL7SUB,0)),U,2)
  ..I 'XDATE S XDATE="Not Transmitted"
+ ..S NUM=NUM+1
+ ..D FMT(NUM,NAME,EDATE,XDATE,AUTO,FMTSTR,.NL,.OUTPUT)
+ ..F JND=1:1:NL D
+ ...S VALMCNT=VALMCNT+1,^TMP(NODE,$J,VALMCNT,0)=OUTPUT(JND)
+ ...S ^TMP(NODE,$J,"IDX",VALMCNT,NUM)=""
+ ...S ^TMP(NODE,$J,"SEL",NUM)=IND
+ ..S VALMCNT=VALMCNT+1
+ ..S LIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,EDATE,XDATE,AUTO)
+ ..S IEN(VALMCNT)=IND
+ S LIST("VALMCNT")=VALMCNT
+ Q
+ ;
+FRE(NUMBER,NAME,EDATE,XDATE,AUTO) ;Format
+ N TAUTO,TDATE,TEMP,TNAME,TSOURCE
+ S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+ S TNAME=$E(NAME,1,27)
+ S TEMP=TEMP_" "_$$LJ^XLFSTR(TNAME,27," ")
+ S TDATE=$$FMTE^XLFDT(EDATE,"5Z")
+ S TEMP=TEMP_" "_$$LJ^XLFSTR(TDATE,20," ")
+ S TDATE=XDATE I TDATE S TDATE=$$FMTE^XLFDT(TDATE,"5Z")
+ S TEMP=TEMP_" "_$$LJ^XLFSTR(TDATE,22," ")
+ S TAUTO=AUTO
+ S TEMP=TEMP_TAUTO
+ Q TEMP

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETM.m

-              r628
+              r636
 PXRMETM ; SLC/PKR/PJH - Extract/Transmission Management ;09/06/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMETM ; SLC/PKR/PJH - Extract/Transmission Management ;05/15/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;Main entry point for PXRM EXTRACT MANAGEMENT
 …
  K ^TMP("PXRMETM",$J)
  N IEN,IND,PLIST
+ D LIST("PXRMETM",.VALMCNT)
+ D LIST(.PLIST,.IEN)
+ M ^TMP("PXRMETM",$J)=PLIST
+ S VALMCNT=PLIST("VALMCNT")
+ F IND=1:1:VALMCNT D
+ .S ^TMP("PXRMETM",$J,"IDX",IND,IND)=IEN(IND)
+ Q
+ ;
+LIST(RLIST,IEN) ;Build a list of extract definition entries.
+ N EPCLASS,IND,FNAME,NAME
+ ;Build the list in alphabetical order.
+ S VALMCNT=0
+ S NAME=""
+ F  S NAME=$O(^PXRM(810.2,"B",NAME)) Q:NAME=""  D
+ .S IND=$O(^PXRM(810.2,"B",NAME,"")) Q:'IND
+ .S FNAME=$P($G(^PXRM(810.2,IND,0)),U)
+ .S EPCLASS=$P($G(^PXRM(810.2,IND,100)),U)
+ .S VALMCNT=VALMCNT+1
+ .S RLIST(VALMCNT,0)=$$FRE(VALMCNT,FNAME,EPCLASS)
+ .S IEN(VALMCNT)=IND
+ S RLIST("VALMCNT")=VALMCNT
+ Q
+ ;
+FRE(NUMBER,NAME,CLASS) ;Format  entry number, name
+ ;and date packed.
+ N TCLASS,TEMP,TNAME,TSOURCE
+ S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+ S TNAME=$E(NAME,1,46)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,60," ")
+ S TCLASS=$S(CLASS="N":"NATIONAL",CLASS="V":"VISN",1:"LOCAL")
+ S TEMP=TEMP_"  "_TCLASS
+ Q TEMP
+ ;
 ENTRY ;Entry code
 …
+ Q
+ ;
-FMT(NUMBER,NAME,CLASS) ;Format  entry number, name
- ;and date packed.
- N TCLASS,TEMP,TNAME,TSOURCE
- S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
- S TNAME=$E(NAME,1,46)
- S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,60," ")
- S TCLASS=$S(CLASS="N":"NATIONAL",CLASS="V":"VISN",1:"LOCAL")
- S TEMP=TEMP_"  "_TCLASS
- Q TEMP
+ ;
-GEN ;Ad hoc report option
- ;Reset Screen Mode
- W IORESET
+ ;
- N IND,LISTIEN,VALMY
- D EN^VALM2(XQORNOD(0))
- ;If there is no list quit.
- I '$D(VALMY) Q
- S PXRMDONE=0
- S IND=""
- F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
- .;Get the ien.
- .S LISTIEN=^TMP("PXRMETM",$J,"SEL",IND)
- .D GENSEL(LISTIEN)
+ ;
- S VALMBCK="R"
+ Q
+ ;
-GENSEL(IEN) ;Report for selected extract definition
- N ANS,BEGIN,END,RTN,TEXT
- D DATES^PXRMEUT(.BEGIN,.END,"Report")
- ;Options
- S RTN="PXRMETM",TEXT="Run compliance report for this period"
- S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,1) Q:'ANS  Q:$D(DUOUT)!$D(DTOUT)
- ;Print Report
- D ADHOC^PXRMETCO(IEN,BEGIN,END)
+ Q
+ ;
 HDR ; Header code
  S VALMHDR(1)="Available Extract Definitions:"
  S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
-HELP(CALL) ;General help text routine
- N HTEXT
- I CALL=1 D
- .S HTEXT(1)="Select EDM to edit/display extract definitions.\\"
- .S HTEXT(2)="Select VSE to view previous extracts or"
- .S HTEXT(3)="initiate a manual extract or transmission."
- D HELP^PXRMEUT(.HTEXT)
+ Q
+ ;
-HLIST ;Extract History
- N IND,LISTIEN,VALMY
- D EN^VALM2(XQORNOD(0))
- ;If there is no list quit.
- I '$D(VALMY) Q
- S PXRMDONE=0
- S IND=""
- F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
- .;Get the ien.
- .S LISTIEN=^TMP("PXRMETM",$J,"SEL",IND)
- .D START^PXRMETH(LISTIEN)
- S VALMBCK="R"
+ Q
+ ;
 …
+ Q
+ ;
-LIST(NODE,VALMCNT) ;Build a list of extract definition entries.
- N EPCLASS,IND,FNAME,NAME
- ;Build the list in alphabetical order.
- S VALMCNT=0
- S NAME=""
- F  S NAME=$O(^PXRM(810.2,"B",NAME)) Q:NAME=""  D
- .S IND=$O(^PXRM(810.2,"B",NAME,"")) Q:'IND
- .S FNAME=$P($G(^PXRM(810.2,IND,0)),U)
- .S EPCLASS=$P($G(^PXRM(810.2,IND,100)),U)
- .S VALMCNT=VALMCNT+1
- .S ^TMP(NODE,$J,VALMCNT,0)=$$FMT(VALMCNT,FNAME,EPCLASS)
- .S ^TMP(NODE,$J,"IDX",VALMCNT,VALMCNT)=""
- .S ^TMP(NODE,$J,"SEL",VALMCNT)=IND
+ Q
+ ;
 PEXIT ;Protocol exit code
  S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
  ;Reset after page up/down etc
  D XQORM
+ Q
+ ;
-PLIST ;Extract Definition Inquiry
- N IND,EPIEN,VALMY
- D EN^VALM2(XQORNOD(0))
- ;If there is no list quit.
- I '$D(VALMY) Q
- S PXRMDONE=0
- S IND=""
- F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
- .;Get the ien.
- .S EPIEN=^TMP("PXRMETM",$J,"SEL",IND)
- .D START^PXRMEPED(EPIEN)
- S VALMBCK="R"
+ Q
+ ;
 …
+ ;
 XSEL ;PXRM EXTRACT MANAGEMENT SELECT ENTRY validation
  N EDIEN,SEL
+ N SEL,IEN
  S SEL=$P(XQORNOD(0),"=",2)
  ;Remove trailing ,
 …
  .W $C(7),!,"Only one item number allowed." H 2
  .S VALMBCK="R"
  I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
  .W $C(7),!,SEL_" is not a valid item number." H 2
  .S VALMBCK="R"
+ ;
  ;Get the list ien.
  S EDIEN=^TMP("PXRMETM",$J,"SEL",SEL)
+ S IEN=^TMP("PXRMETM",$J,"IDX",SEL,SEL)
+ ;
  ;Full screen mode
 …
+ ;
  ;Display Extract Definitions
+ I OPTION="EDM" D START^PXRMEPED(EDIEN)
+ I OPTION="EDM" D
+ .D START^PXRMEPED(IEN)
+ ;
  ;Examine/Run Extract
+ I OPTION="VSE" D START^PXRMETH(EDIEN)
+ I OPTION="VSE" D
+ .D START^PXRMETH(IEN)
+ ;
  ;Examine/Run Extract
+ I OPTION="ERE" D GENSEL(EDIEN)
+ I OPTION="ERE" D
+ .D GENSEL(IEN)
+ ;
  S VALMBCK="R"
+ Q
+ ;
+HELP(CALL) ;General help text routine
+ N HTEXT
+ I CALL=1 D
+ .S HTEXT(1)="Select EDM to edit/display extract definitions."
+ .S HTEXT(2)="extract. Select VSE to view previous extracts or "
+ .S HTEXT(3)="initiate a manual extract or transmission."
+ ;
+ D HELP^PXRMEUT(.HTEXT)
+ Q
+ ;
+GEN ;Ad hoc report option
+ ;
+ ;Reset Screen Mode
+ W IORESET
+ ;
+ N IND,LISTIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S LISTIEN=^TMP("PXRMETM",$J,"IDX",IND,IND)
+ .D GENSEL(LISTIEN)
+ ;
+ S VALMBCK="R"
+ Q
+ ;
+GENSEL(IEN) ;Report for selected extract definition
+ N ANS,BEGIN,END,RTN,TEXT
+ D DATES^PXRMEUT(.BEGIN,.END,"Report")
+ ;Options
+ S RTN="PXRMETM",TEXT="Run compliance report for this period"
+ S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,1) Q:'ANS  Q:$D(DUOUT)!$D(DTOUT)
+ ;Print Report
+ D ADHOC^PXRMETCO(IEN,BEGIN,END)
+ Q
+ ;
+HLIST ;Extract History
+ N IND,LISTIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S LISTIEN=^TMP("PXRMETM",$J,"IDX",IND,IND)
+ .D START^PXRMETH(LISTIEN)
+ S VALMBCK="R"
+ Q
+ ;
+PLIST ;Extract Definition Inquiry
+ N IND,EPIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S EPIEN=^TMP("PXRMETM",$J,"IDX",IND,IND)
+ .D START^PXRMEPED(EPIEN)
+ ;
+ S VALMBCK="R"
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETT.m

-              r628
+              r636
 PXRMETT ; SLC/PJH - Extract Summary Display ;04/09/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;
  ;Main entry point for PXRM EXTRACT SUMMARY
+PXRMETT ; SLC/PKR/PJH - Reminder Patient List Patients ;08/08/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Main entry point for PXRM PATIENT LIST
 START(IEN) N TOGGLE,TOGGLE1,VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
  S X="IORESET"
 …
+ ;
 BLDLIST(IEN,FINDINGS,PATIENT) ;Build workfile.
- ;FINDINGS=1 means display finding totals
  K ^TMP("PXRMETT",$J)
  ;Build a list of extract summary totals.
  N APPL,DATA,DUE,IND,LIST,NDUE,NAPPL,OLIST
  N PLCNT,PLIST,RIEN,RNAME,SARRAY,SEQ,SNAME,STATION,TOT
+ N PLCNT,PLIST,RIEN,RNAME,SARRAY,SNAME,STATION,TOT
  ;Build the list in alphabetical order.
  S VALMCNT=0,OLIST="",PLCNT=0
  S IND=0 F  S IND=$O(^PXRMXT(810.3,IEN,3,IND)) Q:IND'>0  D
+ S IND=0,VALMCNT=0,OLIST="",PLCNT=0
+ F  S IND=$O(^PXRMXT(810.3,IEN,3,IND)) Q:'IND  D
  .S DATA=$G(^PXRMXT(810.3,IEN,3,IND,0)) Q:DATA=""
  .S RIEN=$P(DATA,U,2) Q:'RIEN
+ .S RNAME=$P(^PXD(811.9,RIEN,0),U,3)
+ .I RNAME="" S RNAME=$P(^PXD(811.9,RIEN,0),U,1)
+ .S RNAME=$P($G(^PXD(811.9,RIEN,0)),U)
  .S STATION=$P(DATA,U,3),SARRAY=""
  .D GETS^DIQ(4,STATION,99,"E","SARRAY")
 …
  .S PLIST=$P(DATA,U,4)
  .I PLIST,PLIST'=OLIST D
- ..I PLCNT>0 D
- ...S VALMCNT=VALMCNT+1
- ...S ^TMP("PXRMETT",$J,VALMCNT,0)=""
- ...S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
  ..S PLNAME=$P($G(^PXRMXP(810.5,PLIST,0)),U),OLIST=PLIST Q:PLNAME=""
  ..S VALMCNT=VALMCNT+1,PLCNT=PLCNT+1
 …
  ..S ^TMP("PXRMETT",$J,"SEL",PLCNT)=PLIST
  ..S ^TMP("PXRMETT",$J,VALMCNT,0)=$$RJ^XLFSTR(PLCNT,4," ")_" "_PLNAME
+ ..S VALMCNT=VALMCNT+1
+ ..S ^TMP("PXRMETT",$J,VALMCNT,0)=""
+ ..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
  .S VALMCNT=VALMCNT+1
  .S ^TMP("PXRMETT",$J,VALMCNT,0)=$$FRE(VALMCNT,RNAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE)
+ .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ .S VALMCNT=VALMCNT+1
+ .S ^TMP("PXRMETT",$J,VALMCNT,0)=""
  .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
  .;Finding totals
 …
+ ;
  S ^TMP("PXRMETT",$J,"VALMCNT")=VALMCNT
+ Q
+ ;
+ENTRY ;Entry code
+ D BLDLIST(IEN,TOGGLE,TOGGLE1),XQORM
+ Q
+ ;
+EXIT ;Exit code
+ K ^TMP("PXRMETT",$J)
+ K ^TMP("PXRMETTH",$J)
+ D CLEAN^VALM10
+ D FULL^VALM1
+ S VALMBCK="Q"
+ ;M ^TMP("PXRMETT",$J)=LIST
+ Q
+ ;
 …
+ Q
+ ;
+PBLD(IEN,IND,SUB) ;
+ N ARRAY,NAME,LEN,PCNT,DFN,CNT,USTR
+ S VALMCNT=VALMCNT+1,CNT=0
+ S PCNT=0 F  S PCNT=$O(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT)) Q:PCNT'>0  D
+ .S DFN=$P($G(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT,0)),U) Q:DFN'>0
+ .S NAME=$P($G(^DPT(DFN,0)),U)
+ .S CNT=CNT+1,ARRAY(NAME)=""
+ S ^TMP("PXRMETT",$J,VALMCNT,0)="     "_$$RJ^XLFSTR("Unique Applicable Patients ("_CNT_")",36," ")
+ S USTR=$P($G(^TMP("PXRMETT",$J,VALMCNT,0)),"U"),LEN=$L(USTR)
+ S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ S NAME="" F  S NAME=$O(ARRAY(NAME)) Q:NAME=""  D
+ .S VALMCNT=VALMCNT+1
+ .S ^TMP("PXRMETT",$J,VALMCNT,0)=USTR_$$LJ^XLFSTR(NAME,36," ")
+ .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ S VALMCNT=VALMCNT+1
+ S ^TMP("PXRMETT",$J,VALMCNT,0)="  "
+ S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ Q
+ ;
 FLIST ;Toggle list with/without finding totals
  S TOGGLE=(TOGGLE+1)#2
  I TOGGLE=0 S TOGGLE1=0
+ ;Rebuild Workfile
+ D BLDLIST(IEN,TOGGLE,TOGGLE1)
+ ;Refresh
+ S VALMBCK="R",VALMBG=1
+ Q
+ ;
+PLIST1 ;Toggle list with/without finding totals
+ S TOGGLE1=(TOGGLE1+1)#2
  ;Rebuild Workfile
  D BLDLIST(IEN,TOGGLE,TOGGLE1)
 …
  Q TEMP
+ ;
+ENTRY ;Entry code
+ D BLDLIST(IEN,TOGGLE,TOGGLE1),XQORM
+ Q
+ ;
+EXIT ;Exit code
+ K ^TMP("PXRMETT",$J)
+ K ^TMP("PXRMETTH",$J)
+ D CLEAN^VALM10
+ D FULL^VALM1
+ S VALMBCK="Q"
+ Q
+ ;
 HDR ; Header code
  S VALMHDR(1)="Extract Summary Name: "_$P($G(^PXRMXT(810.3,IEN,0)),U)
  S VALMHDR(2)="      Extract Period: "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,2),"5Z")_" - "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,3),"5Z")
  S VALMHDR(2)=VALMHDR(2)_"   Created: "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,6),"5Z")
+ ;S VALMHDR(3)=VALMHDR(3)_"        Transmitted: "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,4),"5Z")
  S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
 …
+ Q
+ ;
+PBLD(IEN,IND,SUB) ;
+ N ARRAY,NAME,LEN,PCNT,DFN,CNT,USTR
+ S VALMCNT=VALMCNT+1,CNT=0
+ S PCNT=0 F  S PCNT=$O(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT)) Q:PCNT'>0  D
+ .S DFN=$P($G(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT,0)),U) Q:DFN'>0
+ .S NAME=$P($G(^DPT(DFN,0)),U)
+ .S CNT=CNT+1,ARRAY(NAME)=""
+ S ^TMP("PXRMETT",$J,VALMCNT,0)="     "_$$RJ^XLFSTR("Unique Applicable Patients ("_CNT_")",36," ")
+ S USTR=$P($G(^TMP("PXRMETT",$J,VALMCNT,0)),"U"),LEN=$L(USTR)
+ S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ S NAME="" F  S NAME=$O(ARRAY(NAME)) Q:NAME=""  D
+ .S VALMCNT=VALMCNT+1
+ .S ^TMP("PXRMETT",$J,VALMCNT,0)=USTR_$$LJ^XLFSTR(NAME,36," ")
+ .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ S VALMCNT=VALMCNT+1
+ S ^TMP("PXRMETT",$J,VALMCNT,0)="  "
+ S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT SUMMARY SELECT ENTRY",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Item: "
+ Q
+ ;
+XSEL ;PXRM EXTRACT TOTALS SELECT ENTRY validation
+ N SEL,PLIEN
+ S SEL=$P(XQORNOD(0),"=",2)
+ ;Remove trailing ,
+ I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
+ ;Invalid selection
+ I SEL["," D  Q
+ .W $C(7),!,"Only one item number allowed." H 2
+ .S VALMBCK="R"
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
+ .W $C(7),!,SEL_" is not a valid item number." H 2
+ .S VALMBCK="R"
+ ;
+ ;Get the list ien.
+ S PLIEN=^TMP("PXRMETT",$J,"SEL",SEL)
+ ;
+ D START^PXRMLPP(PLIEN)
+ ;
+ S VALMBCK="R"
+ Q
+ ;
 …
  .S PLIEN=^TMP("PXRMETT",$J,"SEL",IND)
  .D START^PXRMLPP(PLIEN)
+ ;
  S VALMBCK="R"
+ Q
+ ;
-PLIST1 ;Toggle list with/without finding totals
- S TOGGLE1=(TOGGLE1+1)#2
- ;Rebuild Workfile
- D BLDLIST(IEN,TOGGLE,TOGGLE1)
- ;Refresh
- S VALMBCK="R",VALMBG=1
+ Q
+ ;
-XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT SUMMARY SELECT ENTRY",0))_U_"1:"_VALMCNT
- S XQORM("A")="Select Item: "
+ Q
+ ;
-XSEL ;PXRM EXTRACT TOTALS SELECT ENTRY validation
- N SEL,PLIEN
- S SEL=$P(XQORNOD(0),"=",2)
- ;Remove trailing ,
- I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
- ;Invalid selection
- I SEL["," D  Q
- .W $C(7),!,"Only one item number allowed." H 2
- .S VALMBCK="R"
- I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
- .W $C(7),!,SEL_" is not a valid item number." H 2
- .S VALMBCK="R"
- ;Get the list ien.
- S PLIEN=^TMP("PXRMETT",$J,"SEL",SEL)
- D START^PXRMLPP(PLIEN)
- S VALMBCK="R"
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETX.m

-              r628
+              r636
+PXRMETX ; SLC/PJH - Run Extract for QUERI ;07/10/2007
+ ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMETX ; SLC/PJH - Run Extract for QUERI ;1/22/07  21:25
+ ;;2.0;CLINICAL REMINDERS;**4,7**;Feb 04, 2005;Build 14
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; 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 St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
 AUTO(ID,PURGE) ;Called from option scheduling (#19.2)
 …
  ;Purge Patient Lists
  D PRGPL^PXRMETXU
+ ;Call the DOQ-IT HL7 generating routine
+ ;D EXTRACT^VEPER7EX(VDATA(810.2,IEN_",",3,"I"),VDATA(810.2,IEN_",",5,"I"))
+ Q
+ ;
 …
+ Q
+ ;
+ACAD ;Auto CAD entry point
+ D AUTO("VOE DOQ-IT CAD EXTRACTION")
+ Q
+ ;
+ADM ;Auto DM entry point
+ D AUTO("VOE DOQ-IT DM EXTRACTION")
+ Q
+ ;
+AHF ;Auto HF entry point
+ D AUTO("VOE DOQ-IT HF EXTRACTION")
+ Q
+ ;
+AHTN ;Auto HTN entry point
+ D AUTO("VOE DOQ-IT HTN EXTRACTION")
+ Q
+ ;
+APC ;Auto PC entry point
+ D AUTO("VOE DOQ-IT PC EXTRACTION")
+ Q
+ ;
 RUN(IEN,NEXT,MODE,PURGE) ;Process extract parameter
  ; IEN is ien of Extract Parameter
 …
+ ;
  N CLASS,FDA,FDAIEN,MSG
+ N PXRMIDOD,PXRMLIST,PXRMNODE,PXRMRULE,PXRMSTRT,PXRMXIEN,PATCREAT,XNAME
+ N ITER
+ N PXRMLIST,PXRMNODE,PXRMRULE,PXRMSTRT,PXRMXIEN,PATCREAT,XNAME
  ;Initialise
  K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J)
 …
  ;Determine output name for patient list and extract summary
  S XNAME=NAME_" "_YEAR_" "_PERIOD
- S NAME=$$GETNAME(XNAME)
- S ITER=$P(NAME,"/",2)
  ;Process (single) Denominator rule into patient list
  N SEQ,SUB
 …
  .S INTP=+$P(DATA,U,5)
  .;Create new patient list
+ .I ITER'="" S LIST=LIST_"/"_ITER
+ .S PATCREAT="Y",PXRMLIST=$$CRLST^PXRMRUL1(LIST,CLASS) Q:'PXRMLIST
+ .S PATCREAT="Y",PXRMLIST=$$CRLST^PXRMRULE(LIST,CLASS) Q:'PXRMLIST
  .;
  .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,YEAR,PERIOD,INDP,INTP,ITER)
+ .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,YEAR,PERIOD,INDP,INTP)
  .;Clear ^TMP lists created for rule
  .D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
  .;Process reminders and finding rules
- .;If include deceased patients is true then set the flag so reminders
- .;will be evaluated for deceased patients.
- .S PXRMIDOD=$S(INDP:1,1:0)
  .D REM^PXRMETXR(SUB,PXRMLIST,PXRMSTRT,PXRMSTOP,PARTYPE)
+ ;
  ;Get the name
  ;S NAME=$$GETNAME(XNAME)
+ S NAME=$$GETNAME(XNAME)
  ;Create extract summary entry
  S FDA(810.3,"+1,",.01)=NAME
 …
  ;Transmit results
  I (MODE=0)!(MODE=2) D TRANS(FDAIEN(1))
+ ;
+ I $$GET^XPAR("SYS","DOQ-IT")="YES" D EXTRACT^VEPER7EX(VDATA(810.2,IEN_",",3,"I"),VDATA(810.2,IEN_",",5,"I"),PXRMLIST)
+ ;
  ;Update extract parameters

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETXR.m

-              r628
+              r636
 PXRMETXR ; SLC/PJH,PKR - Reminder section of extract ;02/22/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMETXR ; SLC/PJH,PKR - Reminder section of extract ;05/01/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ; Called from PXRMETX
 …
  ;lists.
  N APPL,DATA,DEFARR,DEFSITE,DFN,DUE,FIEV,FRIEN,FUTIL,IND,INST
  N PXRMDATE,RCNT,REM,REMSEQ,RIEN,RNAM,STATUS,SUB1,TODAY
+ N PXRMDATE,RCNT,REM,RIEN,RNAM,STATUS,SUB1,TODAY
  N END,START
  ;S START=$H
 …
  ;Scan reminders for this parameter set
  S (RCNT,SUB1)=0
+ S REMSEQ=""
+ F  S REMSEQ=$O(^PXRM(810.2,IEN,10,SUB,10,"B",REMSEQ)) Q:REMSEQ=""  D
+ .F  S SUB1=$O(^PXRM(810.2,IEN,10,SUB,10,"B",REMSEQ,SUB1)) Q:'SUB1  D
+ ..S DATA=$G(^PXRM(810.2,IEN,10,SUB,10,SUB1,0)) Q:DATA=""
+ ..;Reminder ien
+ ..S RIEN=$P(DATA,U,2) Q:'RIEN
+ ..;Evaluation date is period end except if the period is incomplete.
+ ..S PXRMDATE=$S($$FMDIFF^XLFDT(PXRMSTOP,TODAY,2)>0:TODAY,1:PXRMSTOP)
+ ..;Finding Rule
+ ..S FRIEN=$P(DATA,U,3)
+ ..;Reminder print name
+ ..S RNAM=$P($G(^PXD(811.9,RIEN,0)),U,3)
+ ..I RNAM="" S RNAM=$P(^PXD(811.9,RIEN,0),U,1)
+ ..;Save details to REM array
+ ..S RCNT=RCNT+1,REM(RCNT)=RIEN_U_RNAM_U_FRIEN
+ ..;Build list of terms from extract finding rule #810.7
+ ..I FRIEN D FRULE(FRIEN,RCNT,SEQ,.REM,.FUTIL) Q
+ ..;If no extract finding rule defined collect all findings in reminder
+ ..I 'FRIEN D REMF(RIEN,RCNT,SEQ,.REM)
+ F  S SUB1=$O(^PXRM(810.2,IEN,10,SUB,10,SUB1)) Q:'SUB1  D
+ .S DATA=$G(^PXRM(810.2,IEN,10,SUB,10,SUB1,0)) Q:DATA=""
+ .;Reminder ien
+ .S RIEN=$P(DATA,U,2) Q:'RIEN
+ .;Evaluation date is period end except if the period is incomplete.
+ .S PXRMDATE=$S($$FMDIFF^XLFDT(PXRMSTOP,TODAY,2)>0:TODAY,1:PXRMSTOP)
+ .;Finding Rule
+ .S FRIEN=$P(DATA,U,3)
+ .;Reminder print name
+ .S RNAM=$P($G(^PXD(811.9,RIEN,0)),U,3)
+ .;Save details to REM array
+ .S RCNT=RCNT+1,REM(RCNT)=RIEN_U_RNAM_U_FRIEN
+ .;Build list of terms from extract finding rule #810.7
+ .I FRIEN D FRULE(FRIEN,RCNT,SEQ,.REM,.FUTIL) Q
+ .;If no extract finding rule defined collect all findings in reminder
+ .I 'FRIEN D REMF(RIEN,RCNT,SEQ,.REM)
+ ;
  ;Process patient list

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETXU.m

-              r628
+              r636
 PXRMETXU ; SLC/PJH - Extract utilities ;09/06/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMETXU ; SLC/PJH - Extract utilities ;08/03/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
 HELP(CALL) ;General help text routine
 …
  I CALL=4 D
  .S HTEXT(1)="The selected period is the same as next scheduled extract."
  .S HTEXT(2)="Enter 'Y' if this extract will replace the scheduled"
+ .S HTEXT(2)="Enter 'Y' to if this extract will replace the scheduled"
  .S HTEXT(3)="extract. Enter 'N' if you still want the scheduled extract"
  .S HTEXT(4)="to run."
+ .S HTEXT(3)="to run."
+ ;
  D HELP^PXRMEUT(.HTEXT)
+ Q
+ ;
-DELETE(IEN) ;Delete an extract summary.
- I IEN="" Q
- N DA,DELOK,DIK,NAME
- S DELOK=1
- S NAME=$P(^PXRMXT(810.3,IEN,0),U,1)
- ;Must have PXRM MANAGER key in order to delete national extracts.
- I $P($G(^PXRMXT(810.3,IEN,100)),U,1)="N" D
- . S DELOK=$S($D(^XUSEC("PXRM MANAGER",DUZ)):1,1:0)
- . I 'DELOK D
- .. W !!,NAME," is national."
- .. W !,"You cannot delete a national extract summary."
- .. H 2
- I 'DELOK Q
- ;Double check the user really wants to delete.
- S TEXT="Are you sure you want to delete "_NAME
- S DELOK=$$ASKYN^PXRMEUT("N","Are you sure you want to delete "_NAME)
- I 'DELOK Q
- S DA=IEN
- S DIK="^PXRMXT(810.3,"
- D ^DIK
- W !,"Deleting ",NAME
- H 2
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEUT.m

-              r628
+              r636
 PXRMEUT ; SLC/PJH - General extract utilities ;09/06/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMEUT ; SLC/PJH - General extract utilities ;06/27/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;=================================================
 …
+ ;
  ;=================================================
+HELP(HTEXT) ;General help text output routine.
+ N IND,NIN,NOUT,TEXTIN,TEXOUT
+ ;Make sure the text is in a form the formatting routine can handle.
+ S IND="",NIN=0
+ F  S IND=$O(HTEXT(IND)) Q:IND=""  S NIN=NIN+1,TEXTIN(NIN)=HTEXT(IND)
+ D FORMAT^PXRMTEXT(1,72,NIN,.TEXTIN,.NOUT,.TEXTOUT)
+ F IND=1:1:NOUT W !,TEXTOUT(IND)
+HELP(HTEXT) ;General help text routine. Write out the text in the HTEXT
+ ;array.
+ N DIWF,DIWL,DIWR,IC,X
+ S DIWF="C70",DIWL=0,DIWR=70
+ K ^UTILITY($J,"W")
+ S IC=""
+ F  S IC=$O(HTEXT(IC)) Q:IC=""  D
+ . S X=HTEXT(IC)
+ . D ^DIWP
+ W !
+ S IC=0
+ F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
+ . W !,^UTILITY($J,"W",0,IC,0)
+ K ^UTILITY($J,"W")
  W !
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEUT1.m

-              r628
+              r636
 PXRMEUT1 ; SLC/PKR - General extract utilities ;05/08/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMEUT1 ; SLC/PKR - General extract utilities ;08/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;=================================================
+CLDATES ;Cleanup entries in ^TMP("PXRMDDOC",$J) before making date checks.
+ ;For drug findings consolidate PS(55, PS(55NVA, and PSRX( back to
+ ;PSDRUG(.
+ N FI,FIND0,ITEM,GLOBAL,LIST
+ S FIND0=""
+ F  S FIND0=$O(^TMP("PXRMDDOC",$J,FIND0)) Q:FIND0=""  D
+ . S FI=$P(FIND0,U,1)
+ . S GLOBAL=$P(FI,";",2)
+ . I GLOBAL'["PS" Q
+ . S GLOBAL="PSDRUG("
+ . S ITEM=$P(FI,";",1)
+ . S FI=ITEM_";"_GLOBAL_U_$P(FIND0,U,2,11)
+ . S LIST(FIND0)=FI
+ ;
+ S FIND0=""
+ F  S FIND0=$O(LIST(FIND0)) Q:FIND0=""  D
+ . S FI=LIST(FIND0)
+ . S ^TMP("PXRMDDOC",$J,FI)=^TMP("PXRMDDOC",$J,FIND0)
+ . K ^TMP("PXRMDDOC",$J,FIND0)
+ Q
+DCONV(DATE,LBBDT,LBEDT) ;Convert dates to actual values.
+ I DATE=0 Q DATE
+ N PXRMDATE
+ S PXRMDATE=$S(DATE["BDT":LBBDT,1:LBEDT)
+ S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
+ Q $$CTFMD^PXRMDATE(DATE)
+ ;
  ;=================================================
 …
+ ;
  ;=================================================
-DCONV(DATE,LBBDT,LBEDT) ;Convert dates to actual values.
- I DATE=0 Q DATE
- N PXRMDATE
- S PXRMDATE=$S(DATE["BDT":LBBDT,1:LBEDT)
- S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
- Q $$CTFMD^PXRMDATE(DATE)
+ ;
- ;=================================================
 DOCDATES(RULESET,LBBDT,LBEDT,NL,OUTPUT) ;
  N EM,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
  N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,OPER,PXRMFVPL
+ N FINDPA,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
+ N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,PXRMDATE,PXRMFVPL
  N RRIEN,RSDATA,RSDATES,RBDT,REDT,SEQ,SUB
- I $G(PXRMDDOC)=2 D CLDATES
  ;Build the variable pointer list.
  D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL)
 …
  . S SUB=$O(^PXRM(810.4,RULESET,30,"B",SEQ,"")) Q:'SUB
  . S RSDATA=$G(^PXRM(810.4,RULESET,30,SUB,0)) Q:RSDATA=""
- . S OPER=$P(RSDATA,U,3)
- . S OPER=$$EXTERNAL^DILFD(810.41,.03,"",OPER,.EM)
  . S RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1))
  .;Finding rule ien.
 …
  .;Determine RBDT and REDT
  . D RDATES(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT)
+ . S PXRMDATE=LBEDT
+ . S $P(FINDPA(0),U,8)=RBDT,$P(FINDPA(0),U,11)=REDT
  . S NL=NL+1,OUTPUT(NL)=""
  . S NL=NL+1,OUTPUT(NL)="SEQUENCE "_SEQ_" "_$P(FRDATA,U,1)
- . S NL=NL+1,OUTPUT(NL)=" Operation: "_OPER
  .;Term finding rules
  . I FRTYP=1 D TERM(FRTIEN,LBBDT,LBEDT,RBDT,REDT,.PXRMFVPL,.NL,.OUTPUT)
+ . I FRTYP=1 D TERM(FRTIEN,.FINDPA,.PXRMFVPL,.NL,.OUTPUT)
  .;Reminder Definition List Rule
  . I FRTYP=2 D REM(RRIEN,LBBDT,LBEDT,RBDT,REDT,.PXRMFVPL,.NL,.OUTPUT)
+ . I FRTYP=2 D REM(RRIEN,.FINDPA,.PXRMFVPL,.NL,.OUTPUT)
+ Q
+ ;
  ;=================================================
 FMULPRT(FARR,PXRMFVPL,NL,OUTPUT) ;Print the finding multiple
+FMULPRT(DEFARR,FINDPA,PXRMFVPL,NL,OUTPUT) ;Print the finding multiple
  ;information.
+ ;Q
+ N BDT,EDT,DERROR,FNAME,FTYPE,IND,NOCC,TBDT,TEDT,TEMP,VPTR
+ N BDT,EDT,FNAME,FTYPE,IND,NOCC,PFINDPA,TFINDPA,VPTR
  S IND=0
  F  S IND=+$O(FARR(20,IND)) Q:IND=0  D
  . S VPTR=$P(FARR(20,IND,0),U,1)
+ F  S IND=+$O(DEFARR(20,IND)) Q:IND=0  D
+ . S VPTR=$P(DEFARR(20,IND,0),U,1)
  . S FNAME=$$ENTRYNAM^PXRMPTD2(VPTR)
  . S FTYPE=$$FTYPE^PXRMPTD2(VPTR,1)
  . S NL=NL+1,OUTPUT(NL)="  FINDING "_IND_"-"_FTYPE_"."_FNAME
+ . K PFINDPA,TFINDPA
+ . M TFINDPA=DEFARR(20,IND)
  .;Set the finding parameters.
+ . D SSPAR^PXRMUTIL(FARR(20,IND,0),.NOCC,.BDT,.EDT)
+ . D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ . D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
  . S NL=NL+1,OUTPUT(NL)="   Beginning Date/Time: "_$$FMTE^XLFDT(BDT,"5Z")
  . S NL=NL+1,OUTPUT(NL)="   Ending Date/Time:    "_$$FMTE^XLFDT(EDT,"5Z")
- . I $G(PXRMDDOC)'=2 Q
- . S DERROR=0
- . S TEMP=$G(^TMP("PXRMDDOC",$J,$P(FARR(20,IND,0),U,1,11)))
- .;If TEMP is null then no evaluation was required and the check
- .;cannot be made
- . I TEMP="" Q
- . I $P(TEMP,U,1)'=BDT D
- .. S DERROR=1
- .. S NL=NL+1,OUTPUT(NL)="  There is a consistency problem with the beginning date!"
- .. S NL=NL+1,OUTPUT(NL)="  Date used to build the list was: "_$$FMTE^XLFDT($P(TEMP,U,1),"5Z")
- . I $P(TEMP,U,2)'=EDT D
- .. S DERROR=1
- .. S NL=NL+1,OUTPUT(NL)="  There is a consistency problem with the ending date!"
- .. S NL=NL+1,OUTPUT(NL)="  Date used to build the list was: "_$$FMTE^XLFDT($P(TEMP,U,2),"5Z")
- . I DERROR D
- .. S NL=NL+1,OUTPUT(NL)="  Please notify the developers."
- .. ;S NL=NL+1,OUTPUT(NL)="  Please enter a Remedy ticket."
- .. S NL=NL+1,OUTPUT(NL)=" "
+ Q
+ ;
 …
  I RBDT="" S RBDT=0
  I REDT="" S REDT=LBEDT
  I REDT=0 S REDT=DT
+ I REDT=0 S REDT=$$DT^XLFDT
  ;Convert RBDT and REDT to FileMan dates.
  S RBDT=$$DCONV(RBDT,LBBDT,LBEDT)
 …
+ ;
  ;=================================================
 REM(IEN,LBBDT,LBEDT,RBDT,REDT,PXRMFVPL,NL,OUTPUT) ;
+REM(IEN,FINDPA,PXRMFVPL,NL,OUTPUT) ;
  N DEFARR
  D DEF^PXRMLDR(IEN,.DEFARR)
- D DATES^PXRMRUL1(LBBDT,LBEDT,RBDT,REDT,.DEFARR)
  S NL=NL+1,OUTPUT(NL)=" REMINDER DEFINITION "_$P(DEFARR(0),U,1)
  D FMULPRT(.DEFARR,.PXRMFVPL,.NL,.OUTPUT)
+ D FMULPRT(.DEFARR,.FINDPA,.PXRMFVPL,.NL,.OUTPUT)
+ Q
+ ;
  ;=================================================
 TERM(IEN,LBBDT,LBEDT,RBDT,REDT,PXRMFVPL,NL,OUTPUT) ;
+TERM(IEN,FINDPA,PXRMFVPL,NL,OUTPUT) ;
  N TERMARR
  D TERM^PXRMLDR(IEN,.TERMARR)
- D DATES^PXRMRUL1(LBBDT,LBEDT,RBDT,REDT,.TERMARR)
  S NL=NL+1,OUTPUT(NL)=" TERM "_$P(TERMARR(0),U,1)
  D FMULPRT(.TERMARR,.PXRMFVPL,.NL,.OUTPUT)
+ D FMULPRT(.TERMARR,.FINDPA,.PXRMFVPL,.NL,.OUTPUT)
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEVFI.m

-              r628
+              r636
 PXRMEVFI ; SLC/PKR - Driver for finding evaluation. ;04/02/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEVFI ; SLC/PKR - Driver for finding evaluation. ;12/01/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;=====================================================
 …
  . I ENODE="PSNDF(50.6," D EVALFI^PXRMDGEN(DFN,.DEFARR,ENODE,.FIEVAL) Q
  . I ENODE="RAMIS(71," D EVALFI^PXRMRAD(DFN,.DEFARR,ENODE,.FIEVAL) Q
  . I ENODE="YTT(601.71," D EVALFI^PXRMMH(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="YTT(601," D EVALFI^PXRMMH(DFN,.DEFARR,ENODE,.FIEVAL) Q
  ;Evaluate function findings.
  D EVAL^PXRMFF(DFN,.DEFARR,.FIEVAL)
 …
  S FINDPA(11)=DEFARR(20,FINUM,11)
  D GENTERM^PXRMPLST(FINDPA(0),FINUM,.TERMARR)
  D EVALPL^PXRMTERL(.FINDPA,.TERMARR,PLIST)
+ D EVALPL^PXRMTERM(.FINDPA,.TERMARR,PLIST)
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXCF.m

-              r628
+              r636
 PXRMEXCF ; SLC/PKR - Reminder exchange routines for computed findings. ;06/28/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXCF ; SLC/PKR - Reminder exchange routines for computed findings. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;==============================================
 EXISTS(ROUTINE) ;Return true if routine ROUTINE exists.
 …
  ;==============================================
 GETRACT(ATTR,NEWNAME,NAMECHG,RTN,EXISTS) ;Get the action for a routine.
  N ACTION,CHOICES,CSUM,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ECS,IND,MSG
+ N ACTION,CHOICES,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ECS,IND,MSG
  N PCS,ROUTINE,SAME,TEXT,X,Y
  S NEWNAME=""
+ ;If the routine exists compare the existing routine checksum with the
+ ;the checksum of the routine in the packed definition.
  S ROUTINE=ATTR("NAME")
  I EXISTS="" S EXISTS=$$EXISTS^PXRMEXCF(ROUTINE)
  S CHOICES=$S(EXISTS:"COQS",1:"CIQS")
  I EXISTS D
+ .;If the routine exists compare the existing routine checksum with the
+ .;the checksum of the routine in the packed definition.
+ . S CSUM=$$RTNCS^PXRMEXCS(ROUTINE)
+ . S SAME=$S(ATTR("CHECKSUM")=CSUM:1,1:0)
+ . S SAME=$$SAME(.ATTR,.RTN)
  . S TEXT(1)="Routine "_ROUTINE_" already exists "
+ . I SAME D
+ .. S TEXT(1)=TEXT(1)_"and the packed routine is identical, skipping."
+ .. W !,TEXT(1),! H 2
+ .. S ACTION="S"
+ . I 'SAME D
+ .. S TEXT(1)=TEXT(1)_"but the packed routine is different,"
+ .. S TEXT(2)="what do you want to do?"
+ .. W !,TEXT(1),!,TEXT(2)
+ .. S DIR("B")="O"
+ .. S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
+ . I SAME S TEXT(1)=TEXT(1)_"and the packed routine is identical,"
+ . I 'SAME S TEXT(1)=TEXT(1)_"but the packed routine is different,"
+ . S TEXT(2)="what do you want to do?"
+ . D EN^DDIOL(.TEXT)
+ . S DIR("B")="S"
+ . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
  E  D
  . W !!,"Routine "_ROUTINE_" is new, what do you want to do?"
+ . W !!,"Routine "_ROUTINE_" is NEW, what do you want to do?"
  . S DIR("B")="I"
  . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
+ ;
  I (ACTION="Q")!(ACTION="S") Q ACTION
+ I ACTION="Q" Q ACTION
+ ;
  I ACTION="C" D
 …
  Q ACTION
+ ;
+ ;==============================================
+SAME(ATTR,RTN) ;Compare the existing routine and the new version
+ ;in RTN to see if they are the same.
+ N ECS,DIF,NEWCS,RT,SAME,X,XCNP
+ ;Load the existing routine into RT.
+ S XCNP=0
+ S DIF="RT("
+ S X=ATTR("NAME")
+ X ^%ZOSF("LOAD")
+ S ECS=$$ROUTINE^PXRMEXCS(.RT)
+ K RT
+ S NEWCS=$$ROUTINE^PXRMEXCS(.RTN)
+ S SAME=$S(ECS=NEWCS:1,1:0)
+ Q SAME
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXCS.m

-              r628
+              r636
+PXRMEXCS ; SLC/PKR - Routines to compute checksums. ;07/27/2007
+ ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;====================================================
+CHECKSUM(ATTR,START,END) ;Get the the checksum for a packed reminder
+ ;component and load it into the attribute array.
+ N CS,LINE
+ ;If checksum is in packed component return it otherwise calculate it.
+ I ATTR("FILE NUMBER")=0 D
+ . S LINE=^PXD(811.8,PXRMRIEN,100,START-3,0)
+ . S CS=$$GETTAGV^PXRMEXU3(LINE,"<CHECKSUM>")
+ . I CS="" S CS=$$PRTNCS(PXRMRIEN,START,END)
+ I ATTR("FILE NUMBER")>0 D
+ . S LINE=^PXD(811.8,PXRMRIEN,100,START-2,0)
+ . S CS=$$GETTAGV^PXRMEXU3(LINE,"<CHECKSUM>")
+ . I CS="" S CS=$$PFDACS(PXRMRIEN,START,END)
+ S ATTR("CHECKSUM")=CS
+ Q
+ ;
+ ;====================================================
+DIQOUTCS(DIQOUT) ;Return checksum for a processed DIQOUT array.
+ N CS,DATA,FIELD,FNUM,IENS,IND,SFN,STRING,TARGET,TEXT,WP
+ S FNUM=$O(DIQOUT(""))
+ D FIELD^DID(FNUM,"EDIT HISTORY","","SPECIFIER","TARGET")
+ S SFN=+$G(TARGET("SPECIFIER"))
+ S (CS,FNUM)=0
+ F  S FNUM=$O(DIQOUT(FNUM)) Q:FNUM=""  D
+ . I FNUM=SFN Q
+ . S IENS=""
+ . F  S IENS=$O(DIQOUT(FNUM,IENS)) Q:IENS=""  D
+ .. S FIELD=0
+ .. F  S FIELD=$O(DIQOUT(FNUM,IENS,FIELD)) Q:FIELD=""  D
+ ... S DATA=DIQOUT(FNUM,IENS,FIELD)
+ ... S TEXT=FNUM_$L(IENS,",")_FIELD_DATA
+ ... S CS=$$CRC32^XLFCRC(TEXT,CS)
+ ... I DATA["WP-start" F IND=1:1:$P(DATA,"~",2) D
+ .... S TEXT=DIQOUT(FNUM,IENS,FIELD,IND)
+ .... S CS=$$CRC32^XLFCRC(TEXT,CS)
+ Q CS
+ ;
+PXRMEXCS ; SLC/PKR - Routines to compute checksums. ;12/21/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;====================================================
 FILE(FILENUM,IEN) ;Return checksum for entry IEN in file FILENUM.
+ N CS,DIQOUT,IENROOT,MSG
+ D GETS^DIQ(FILENUM,IEN,"**","N","DIQOUT","MSG")
+ ;Remove edit history from all reminder files.
+ D RMEH^PXRMEXPU(FILENUM,.DIQOUT,1)
+ ;Convert the iens to the FDA adding form.
+ D CONTOFDA^PXRMEXPU(.DIQOUT,.IENROOT)
+ S CS=$$DIQOUTCS(.DIQOUT)
+ N CS,LC,REF,ROOT,TARGET
+ D FILE^DID(FILENUM,"","GLOBAL NAME","TARGET")
+ S ROOT=$$CREF^DILF(TARGET("GLOBAL NAME"))
+ K ^TMP($J,"PXRMEXCS")
+ M ^TMP($J,"PXRMEXCS")=@ROOT@(IEN)
+ S REF="^TMP($J,""PXRMEXCS"")"
+ S REF=$NA(@REF)
+ S (CS,LC)=0
+ F  S REF=$Q(@REF) Q:REF'["PXRMEXCS"  S LC=LC+1,CS=CS+$$LINECS(LC,@REF)
+ K ^TMP($J,"PXRMEXCS")
  Q CS
+ ;
 …
  N CS,IND,LINE
  S (CS,IND)=0
+ F  S IND=$O(@GBL@(IND)) Q:+IND=0  S LINE=@GBL@(IND),CS=$$CRC32^XLFCRC(LINE,CS)
+ F  S IND=$O(@GBL@(IND)) Q:+IND=0  S LINE=@GBL@(IND),CS=CS+$$LINECS(IND,LINE)
+ Q CS
+ ;
+ ;====================================================
+LINECS(LINENUM,STRING) ;Return checksum of line number LINEUM whose contents
+ ;is STRING.
+ N CS,IND,LEN
+ S CS=0
+ S LEN=$L(STRING)
+ F IND=1:1:LEN S CS=CS+($A(STRING,IND)*(LINENUM+IND))
  Q CS
+ ;
 …
  S NLINES=+$P($G(^XMB(3.9,XMZ,2,0)),U,3)
  S CS=0
+ F IND=1:1:NLINES S LINE=$G(^XMB(3.9,XMZ,2,IND,0)),CS=$$CRC32^XLFCRC(LINE,CS)
+ Q CS
+ ;
+ ;====================================================
+PFDACS(IEN,FDASTART,FDAEND) ;Return checksum for FDA array of packed
+ ;reminder component.
+ N CS,DATA,IENS,IND,JND,FIELD,FNUM,SFN,TARGET,TEMP,TEXT
+ S TEMP=^PXD(811.8,IEN,100,FDASTART,0)
+ S FNUM=$P(TEMP,";",1)
+ D FIELD^DID(FNUM,"EDIT HISTORY","","SPECIFIER","TARGET")
+ S SFN=+$G(TARGET("SPECIFIER"))
+ S CS=0
+ F IND=FDASTART:1:FDAEND D
+ . S TEMP=^PXD(811.8,IEN,100,IND,0)
+ . S DATA=$P(TEMP,"~",2,99)
+ . S TEMP=$P(TEMP,"~",1)
+ . S FNUM=$P(TEMP,";",1)
+ . I FNUM=SFN Q
+ . I FNUM="Exchange Stub" Q
+ . S IENS=$P(TEMP,";",2)
+ . S FIELD=$P(TEMP,";",3)
+ . S TEXT=FNUM_$L(IENS,",")_FIELD_DATA
+ . S CS=$$CRC32^XLFCRC(TEXT,CS)
+ . I DATA["WP-start" F JND=1:1:$P(DATA,"~",2) D
+ .. S IND=IND+1
+ .. S TEXT=^PXD(811.8,IEN,100,IND,0)
+ .. S CS=$$CRC32^XLFCRC(TEXT,CS)
+ F IND=1:1:NLINES S LINE=$G(^XMB(3.9,XMZ,2,IND,0)),CS=CS+$$LINECS(IND,LINE)
  Q CS
+ ;
 …
 ROUTINE(RA) ;Return checksum for a routine loaded in array RA. RA has the
  ;form created by ^%ZOSF("LOAD") i.e, RA(1,0) ... RA(N,0).
  N CS,IND,TEXT
+ N CS,IND,LINE
  S (CS,IND)=0
+ ;Get rid of the build number on the second line.
+ S RA(2,0)=$P(RA(2,0),";",1,6)
+ F  S IND=$O(RA(IND)) Q:+IND=0  D
+ . S TEXT=RA(IND,0)
+ . S CS=$$CRC32^XLFCRC(RA(IND,0),CS)
+ F  S IND=$O(RA(IND)) Q:+IND=0  S CS=CS+$$LINECS(IND,RA(IND,0))
  Q CS
+ ;
  ;====================================================
 RTNCS(ROUTINE) ;Return checksum for a routine ROUTINE.
+RTN(ROUTINE) ;Return checksum for a routine ROUTINE.
  N CS,DIF,RA,X,XCNP
  S XCNP=0
 …
  Q CS
+ ;
- ;====================================================
-PRTNCS(IEN,START,END) ;Return checksum for a packed routine.
- N CS,IND,SL,TEXT
- S CS=0,SL=START+1
- F IND=START:1:END D
- . S TEXT=^PXD(811.8,IEN,100,IND,0)
- . ;Get rid of the build number on the second line.
- . I IND=SL S TEXT=$P(TEXT,";",1,6)
- . S CS=$$CRC32^XLFCRC(TEXT,CS)
- Q CS
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXDG.m

-              r628
+              r636
 PXRMEXDG ;SLC/PJH - Reminder Dialog Exchange index build ;05/16/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXDG ;SLC/PJH - Reminder Dialog Exchange index build ;02/25/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;=====================================================================
 DIALOG(RIEN,DLIST,FLIST,OLIST,TLIST,SPONLIST) ;
+DIALOG(RIEN,DLIST,FLIST,OLIST,TLIST) ;
+ ;
  ;Routine to get dialog details for a given reminder
 …
  S DCNT=0,FCNT=0,RCNT=0,TCNT=0
  ;Get details
+ D GETSPON^PXRMEXPR(801.41,DIEN,.SPONLIST)
+ D DGET(DIEN,.SPONLIST)
+ D DGET(DIEN)
+ ;
  ;Now build the dialog list (components first)
 …
  N CNT,COUNT,DTYP
  S COUNT=0
+ F DTYP="RESULT ELEMENT" D
+ .S CNT=0 F  S CNT=$O(TEMP(DTYP,CNT)) Q:CNT'>0  D
+ ..S DIEN=$G(TEMP(DTYP,CNT)) Q:DIEN'>0
+ ..S COUNT=COUNT+1,DLIST("DIALOG",COUNT,DIEN)=""
+ ;
+ F DTYP="RESULT" D
+ .S CNT=0 F  S CNT=$O(TEMP(DTYP,CNT)) Q:CNT'>0  D
+ ..S DIEN=$G(TEMP(DTYP,CNT)) Q:DIEN'>0
+ ..S COUNT=COUNT+1,DLIST("DIALOG",COUNT,DIEN)=""
+ ;
+ ;F DTYP="RESULT","DIALOG" D
+ F DTYP="DIALOG" D
+ F DTYP="RESULT","DIALOG" D
  .F CNT=1:1 S DIEN=$G(TEMP(DTYP,CNT)) Q:'DIEN  D
  ..S COUNT=COUNT+1,DLIST("DIALOG",COUNT,DIEN)=""
 …
  ;Get the dialog components
  ;-------------------------
 DGET(D0,SPONLIST) ;Save dialog ien
+DGET(D0) ;Save dialog ien
  N D1
  I $G(D0)=83
  I $G(^PXRMD(801.41,D0,49))'="",$P(^PXRMD(801.41,D0,49),U,3)>0 D
  .S D1=$P($G(^PXRMD(801.41,D0,49)),U,3) D DGET1(D0,.SPONLIST) D DGET1(D1,.SPONLIST)
  E  D DGET1(D0,.SPONLIST)
+ Q
 DGET1(D0,SPONLIST) ;
+ .S D1=$P($G(^PXRMD(801.41,D0,49)),U,3) D DGET1(D0) D DGET1(D1)
+ E  D DGET1(D0)
+ Q
+DGET1(D0) ;
  S DCNT=DCNT+1,DARRAY(DCNT)=D0
  ;And details (except for reminder dialog)
  I DCNT>1 D
- .D GETSPON^PXRMEXPR(801.41,D0,.SPONLIST)
  .;Finding items
  .D DFIND(D0)
 …
  .S DDATA=$G(^PXRMD(801.41,DCOMP,0)) Q:DDATA=""
  .;Exclude national PXRM prompts
  .I +$G(PXRMINST)=0,$E(DDATA,1,4)="PXRM",$P($G(^PXRMD(801.41,DCOMP,100)),U)="N" Q
+ .I $E(DDATA,1,4)="PXRM",$P($G(^PXRMD(801.41,DCOMP,100)),U)="N" Q
  .;Sub-components
  .D DGET(DCOMP,.SPONLIST)
+ .D DGET(DCOMP)
  .;I $G(DCOMP1)'="" D DGET(DCOMP1) S DCOMP1=""
+ Q
 …
  ;---------------------------
 DRESULT(DIEN) ;
  N CNT,RIEN,RECNT,RGCNT
+ N RIEN
  ;Result Group/Element pointer
+ S RECNT=$O(TEMP("RESULT ELEMENT",""),-1)
+ S RGCNT=$O(TEMP("RESULT",""),-1)
+ S CNT=0
+ F  S CNT=$O(^PXRMD(801.41,DIEN,51,CNT)) Q:CNT'>0  D
+ .S RIEN=$P($G(^PXRMD(801.41,DIEN,51,CNT,0)),U) Q:RIEN'>0
+ .;S RIEN=$P($G(^PXRMD(801.41,DIEN,0)),U,15) Q:'RIEN  Q:$D(RESULT(RIEN))
+ .;Result group compoments
+ .N DSUB,REIEN
+ .S DSUB=0
+ .F  S DSUB=$O(^PXRMD(801.41,RIEN,10,DSUB)) Q:'DSUB  D
+ ..;Get result element
+ ..S REIEN=$P($G(^PXRMD(801.41,RIEN,10,DSUB,0)),U,2) Q:'REIEN
+ ..Q:'$D(^PXRMD(801.41,REIEN,0))
+ ..;If element exists get save it
+ ..S RECNT=RECNT+1,TEMP("RESULT ELEMENT",RECNT)=REIEN
+ ..;S RCNT=RCNT+1,OUTPUT("RESULT",RCNT)=REIEN
+ .;
+ .;Save result group
+ .S RGCNT=RGCNT+1,TEMP("RESULT",RGCNT)=RIEN
+ .;S RCNT=RCNT+1,RESULT(RIEN)="",TEMP("RESULT",RCNT)=RIEN
+ S RIEN=$P($G(^PXRMD(801.41,DIEN,0)),U,15) Q:'RIEN  Q:$D(RESULT(RIEN))
+ ;Result group compoments
+ N DSUB,REIEN
+ S DSUB=0
+ F  S DSUB=$O(^PXRMD(801.41,RIEN,10,DSUB)) Q:'DSUB  D
+ .;Get result element
+ .S REIEN=$P($G(^PXRMD(801.41,RIEN,10,DSUB,0)),U,2) Q:'REIEN
+ .Q:'$D(^PXRMD(801.41,REIEN,0))
+ .;If element exists get save it
+ .S RCNT=RCNT+1,OUTPUT("RESULT",RCNT)=REIEN
+ ;
+ ;Save result group
+ S RCNT=RCNT+1,RESULT(RIEN)="",TEMP("RESULT",RCNT)=RIEN
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXFI.m

-              r628
+              r636
 PXRMEXFI ; SLC/PKR/PJH - Exchange utilities for file entries.;07/05/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXFI ; SLC/PKR/PJH - Exchange utilities for file entries.;12/21/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;==============================================
 DELALL(FILENUM,NAME) ;Delete all file entries named NAME.
 …
  S DIK=$$ROOT^DILFD(FILENUM)
  D ^DIK
+ Q
+ ;
- ;==============================================
-FEIMSG(SAME,ATTR) ;Output the general file exits install message.
- N IND,NOUT,TEXT,TEXTO
- S TEXT(1)=ATTR("FILE NAME")_" entry named "_ATTR("NAME")_" already exists"
- I SAME D
- . S TEXT(2)="and the packed component is identical, skipping."
- . S TEXT(3)=" "
- . D FORMAT^PXRMTEXT(1,70,3,.TEXT,.NOUT,.TEXTO)
- . F IND=1:1:NOUT W !,TEXTO(IND)
- . H 2
- I 'SAME D
- . S TEXT(2)="but the packed component is different, what do you want to do?"
- . D FORMAT^PXRMTEXT(1,70,2,.TEXT,.NOUT,.TEXTO)
- . F IND=1:1:NOUT W !,TEXTO(IND)
+ Q
+ ;
 …
  ;Mental Health Instruments not allowed.
  I FILENUM=601 Q 0
- I FILENUM=601.71 Q 0
+ ;
  I FILENUM=790.404 Q 0
 …
+ ;
  ;==============================================
+GETFACT(PT01,ATTR,NEWPT01,NAMECHG,IEN) ;Get the action for a file.
+ N ACTION,CHOICES,CSUM,DIR,FILENUM,MSG,RESULT
+ N SAME,X,Y
+GETFACT(PT01,ATTR,NEWPT01,NAMECHG,EXISTS) ;Get the action for a file.
+ N ACTION,CHOICES,DIR,FILENUM,MSG,RESULT,X,Y
  ;See if this entry is already defined.
 CHK ;
  S NEWPT01=""
+ S (ATTR("NAME"),ATTR("PT01"))=PT01
  S FILENUM=ATTR("FILE NUMBER")
+ I IEN="" S IEN=$$EXISTS^PXRMEXIU(FILENUM,PT01)
+ I IEN D
+ .;If the entry already exists compare the existing entry checksum
+ .;with the packed entry checksum.
+ . S CSUM=$$FILE^PXRMEXCS(ATTR("FILE NUMBER"),IEN)
+ . S SAME=$S(ATTR("CHECKSUM")=CSUM:1,1:0)
+ . D FEIMSG(SAME,.ATTR)
+ . I SAME S ACTION="S"
+ . I 'SAME D
+ .. S CHOICES=$S(FILENUM=801.41:"CMOQS",FILENUM=811.5:"CMOQS",1:"COQS")
+ .. S DIR("B")="O"
+ .. S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
+ I EXISTS="" S EXISTS=$$EXISTS^PXRMEXIU(FILENUM,PT01)
+ ;Check for identical file entry can be made here.
+ I EXISTS D
+ . W !!,ATTR("FILE NAME")," entry ",PT01," already EXISTS,"
+ . W !,"what do you want to do?"
+ . S CHOICES=$S(FILENUM=801.41:"CMOQS",FILENUM=811.5:"CMOQS",1:"COQS")
+ . S DIR("B")="S"
+ . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
  E  D
  . W !!,ATTR("FILE NAME")," entry ",PT01," is NEW,"
 …
+ ;
  ;==============================================
 SETATTR(ATTR,FILE,PT01) ;Set the file attributes for the file FILE.
+SETATTR(ATTR,FILE) ;Set the file attributes for the file FILE.
  N MSG
  S ATTR("FILE NUMBER")=FILE
 …
  D FIELD^DID(FILE,.01,"","FIELD LENGTH","ATTR","MSG")
  S ATTR("MIN FIELD LENGTH")=3
- S (ATTR("NAME"),ATTR("PT01"))=PT01
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXID.m

-              r628
+              r636
 PXRMEXID ;SLC/PJH - Reminder Dialog Exchange Install Routine.;08/16/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXID ;SLC/PJH - Reminder Dialog Exchange Install Routine.;11/14/2003
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;==================================================
 …
  ;------------------------------------------------
 INSALL N ALL,DIROUT,DIRUT,DTOUT,DUOUT,IND,PXRMDONE
+ K ^TMP("PXRMEXIA",$J)
+ ;
  ;Set the install date and time.
  S IND="",PXRMDONE=0
+ S IND="",PXRMDONE=0,^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
+ ;
  ;Go to full screen mode.
 …
  S DNAME=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM"))
  D EXIST^PXRMEXIX(.ALL,DNAME,"reminder dialog","")
- I ALL=0 D DISP^PXRMEXLD(PXRMMODE) Q
+ ;
  ;Lock the entire file
  Q:'$$LOCK
+ F  S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:(IND="")!(PXRMDONE)  D
+ ;
+ ;Install all components
+ F  S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:(+IND=0)!(PXRMDONE)  D
  .D INSCOM(IND,1)
+ ;
 …
  F  S ISEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",NAME,ISEQ)) Q:'ISEQ  D
  .S IDATA=$G(^TMP("PXRMEXTMP",$J,"DMAP",NAME,ISEQ)) Q:IDATA=""
+ .S DNAME=$P(IDATA,U) Q:DNAME=""
+ .;
+ .I $D(^TMP("PXRMEXTMP",$J,"DREPL"))>0 D
+ ..S REPL=$$CHKREPL^PXRMEXD1(NAME) I REPL>0 D INSREPL(NAME,REPL,.INAME)
+ .S INAME(DNAME)=""
+ .;Q:$$PXRM(DNAME)  S INAME(DNAME)=""
+ .S DNAME=$P(IDATA,U) Q:DNAME=""  Q:$$PXRM(DNAME)  S INAME(DNAME)=""
  .;Check for descendants
  .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) D INSBLD(DNAME,.INAME)
+ Q
- ;Build list of replacement names
- ;-------------------------------
-INSREPL(NAME,REPL,INAME) ;
- N DNAME,IDATA,ISEQ
- S ISEQ=0
- S IDATA=$G(^TMP("PXRMEXTMP",$J,"DREPL",REPL,NAME)) Q:IDATA=""
- S DNAME=$P(IDATA,U) Q:DNAME=""  S INAME(DNAME)=""
- ;S DNAME=$P(IDATA,U) Q:DNAME=""  Q:$$PXRM(DNAME)  S INAME(DNAME)=""
- ;Check for descendants
- I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) D INSBLD(DNAME,.INAME)
+ Q
+ ;
 …
  ;---------------------
 INSCOM(IND,SILENT) ;
  N ACTION,ATTR,CSUM,DTYP,EXIEN,END,EXISTS,FILENUM,IND120,JND120
  N NEWPT01,PT01,START,REPL,SAME,TEMP
+ N ACTION,ATTR,DTYP,EXIEN,END,EXISTS,FILENUM,IND120,JND120
+ N NEWPT01,PT01,START,TEMP
  S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND),FILENUM=$P(TEMP,U,1)
  S EXISTS=$P(TEMP,U,4),START=$P(TEMP,U,2),END=$P(TEMP,U,3) Q:START=""
 …
+ ;
  ;Check for descendents
+ S REPL=$$CHKREPL^PXRMEXD1(PT01)
+ I 'SILENT&($$INSDSC(PT01)!(REPL>0)) D  Q:PXRMDONE
+ I 'SILENT,$$INSDSC(PT01) D  Q:PXRMDONE
  .N ANS,INDS,TEXT
  .S TEXT(1)=PT01_" ("_DTYP_") contains sub-components."
 …
  .;Give option to install all descendents
  .D ASK^PXRMEXIX(.ANS,.TEXT,1) Q:PXRMDONE
- .I $G(ANS)="N" S PXRMDONE=1 Q
  .I $G(ANS)="Y" D
  ..S INDS=IND
  ..N IDATA,INAME,IND
- ..I REPL>0 D INSREPL(PT01,REPL,.INAME)
  ..;Build list of decendents to install
  ..D INSBLD(PT01,.INAME)
 …
  ...I $D(INAME(PT01)) D INSCOM(IND,1)
+ ;
+SETENTRY ;
+ D SETATTR^PXRMEXFI(.ATTR,FILENUM,PT01)
+ S ACTION=""
+ D SETATTR^PXRMEXFI(.ATTR,FILENUM)
  ;Double check that it hasn't been installed
  S EXIEN=$$EXISTS^PXRMEXIU(801.41,PT01)
  I EXIEN,'EXISTS S EXISTS=1
+ I EXISTS D
+ . D CHECKSUM^PXRMEXCS(.ATTR,START,END)
+ . S CSUM=$$FILE^PXRMEXCS(ATTR("FILE NUMBER"),EXIEN)
+ . S SAME=$S(ATTR("CHECKSUM")=CSUM:1,1:0)
+ . I SAME D FEIMSG^PXRMEXFI(SAME,.ATTR) S ACTION="S",(PXRMNMCH,NEWPT01)=""
+ I ACTION="" D
+ .;If all components installed the default is 'Install or Overwrite'
+ . S:ALL ACTION=$S(EXISTS:"O",1:"I"),(PXRMNMCH,NEWPT01)=""
+ . S:'ALL ACTION=$$GETFACT^PXRMEXFI(PT01,.ATTR,.NEWPT01,.PXRMNMCH,EXIEN)
+ ;If all components installed the default is 'Install or Overwrite'
+ S:ALL ACTION=$S(EXISTS:"O",1:"I"),(ATTR("NAME"),ATTR("PT01"))=PT01,PXRMNMCH="",NEWPT01=""
+ S:'ALL ACTION=$$GETFACT^PXRMEXFI(PT01,.ATTR,.NEWPT01,.PXRMNMCH,EXISTS)
  ;Save what was done for the installation summary.
  S ^TMP("PXRMEXIAD",$J,IND,ATTR("FILE NAME"),ATTR("PT01"),ACTION)=NEWPT01
+ S ^TMP("PXRMEXIA",$J,IND,ATTR("FILE NAME"),ATTR("PT01"),ACTION)=NEWPT01
  ;Clear heading
  S VALMHDR(2)=""
 …
  F  S SUB=$O(^TMP("PXRMEXTMP",$J,"DMAP",NAME,SUB)) Q:'SUB  D  Q:DFOUND
  .S DATA=$G(^TMP("PXRMEXTMP",$J,"DMAP",NAME,SUB)) Q:DATA=""
+ .S DFOUND=1
+ .;I '$$PXRM($P(DATA,U)) S DFOUND=1
+ .I '$$PXRM($P(DATA,U)) S DFOUND=1
  Q DFOUND
+ ;
-INSREPL1(NAME) ;
- N DATA,DFOUND,SUB
- S DFOUND=0,SUB=0
- F  S SUB=$O(^TMP("PXRMEXTMP",$J,"DREPL",NAME,SUB)) Q:'SUB  D  Q:DFOUND
- .S DATA=$G(^TMP("PXRMEXTMP",$J,"DREPL",NAME,SUB)) Q:DATA=""
- .S DFOUND=1
- Q DFOUND
  ;Option to link dialog to a reminder
  ;-----------------------------------
 …
  D EN^VALM2(XQORNOD(0))
+ ;
+ K ^TMP("PXRMEXIA",$J)
  ;Set the install date and time.
  S ALL="",PXRMDONE=0
+ S ALL="",PXRMDONE=0,^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
+ ;
  ;Lock the entire file
 …
+ ;
  S IND=0
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D INSCOM(IND,0)
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .D INSCOM(IND,0)
+ ;
  ;Clear locks
 …
  ;Ignore non-PXRM
  I $E(NAME,1,4)'="PXRM" Q 0
- N DIEN,RESULT
- I $G(PXRMINST)=1 D  Q RESULT
- .S RESULT=0
- .S DIEN=$O(^PXRMD(801.41,"B",NAME,"")) I 'DIEN Q
- .I $P($G(^PXRMD(801.41,DIEN,100)),U)'="N" Q
- .I ($P($G(^PXRMD(801.41,DIEN,0)),U,4)="P")!($P($G(^PXRMD(801.41,DIEN,0)),U,4)="F") S RESULT=1
+ ;
  ;Check if this is a national code
+ N DIEN
  S DIEN=$O(^PXRMD(801.41,"B",NAME,""))
  ;If not found abort
  I 'DIEN Q 0
- ;if result group/element quit
- I $P($G(^PXRMD(801.41,DIEN,0)),U,4)="S"!($P($G(^PXRMD(801.41,DIEN,0)),U,4)="T") Q 0
  ;Check class
  I $P($G(^PXRMD(801.41,DIEN,100)),U)="N" Q 1

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m

-              r628
+              r636
 PXRMEXIU ; SLC/PKR/PJH - Utilities for installing repository entries. ;07/27/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMEXIU ; SLC/PKR/PJH - Utilities for installing repository entries. ;06/23/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;===============================================
 DEF(FDA,NAMECHG) ;Check the reminder definition to make sure the related
 …
+ ;
  ;Linked reminder dialog field 51.
  S LRD=$G(FDA(811.9,IENS,51))
  S IEN=$S(LRD="":0,1:+$O(^PXRMD(801.41,"B",LRD,"")))
+ S LRD=+$G(FDA(811.9,IENS,51))
+ S IEN=$$EXISTS^PXRMEXIU(801.41,LRD)
  I IEN=0 K FDA(811.9,IENS,51)
+ ;
 …
+ ;
  ;===============================================
+SAME(ATTR,TA,NAME) ;Check existing entry and entry in packed reminder
+ ;definition to see if they are identical.
+ ;Present version only works for computed finding routines, other
+ ;types of entries can be added later.
+ N SAME
+ I ATTR("FILE NAME")="COMPUTED FINDING ROUTINE" S SAME=$$SAME^PXRMEXCF(.ATTR,.TA,NAME)
+ E  S SAME=1
+ Q SAME
+ ;
+ ;===============================================
 TERM(FDA,NAMECHG) ;Check the reminder term to make sure all the
  ;findings exist.

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXIX.m

-              r628
+              r636
 PXRMEXIX ;SLC/PJH - Reminder Dialog Exchange checks. ;10/10/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXIX ;SLC/PJH - Reminder Dialog Exchange checks. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;=====================================================================
 …
  ...S CNT=CNT+1,FIRST=0,TEXT(CNT)=DNAME_" ("_DTYP_")"
  ..S CNT=CNT+1,TEXT(CNT)=""
  S TEXT="Install "_DTYP_" and all components with no further changes: "
+ S TEXT="Install "_DTYP_" and all components with no further changes:"
  ;Give option to install all descendents
  D ASK(.ANS,.TEXT,2) I $G(ANS)="Y" S ALL=1
- I $G(ANS)="N" S ALL=0
+ Q
+ ;
 …
+ ;
  I CALL=1 D
  .S HTEXT(1)="Enter 'Yes' to install all sub-components or"
+ .S HTEXT(1)="Enter 'Yes' to if you are installing all sub-components or"
  .S HTEXT(2)="enter 'No' to install only the selected dialog."
  I CALL=2 D
  .S HTEXT(1)="Enter 'Yes' to install without changes."
  .S HTEXT(2)="Enter 'No' to install with changes."
+ .S HTEXT(1)="Enter 'Yes' to if you are installing without changes."
+ .S HTEXT(2)="enter 'No' to install with changes."
  I CALL=3 D
  .S HTEXT(1)="Select IFE to INSTALL reminder or dialog from this exchange"

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLB.m

-              r628
+              r636
 PXRMEXLB ;SLC/PJH - Reminder Dialog Exchange. ;05/16/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXLB ;SLC/PJH - Reminder Dialog Exchange. ;07/01/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;=====================================================================
 …
  ;-------------------------------
 DBUILD(IND,NITEMS,FILENUM) ;
+ N DARRAY,DDATA,DDLG,DEND,DLOC,DMAP,DNAM,DNODE,DSEQ,DSTRT,DSUB,FILE,JND
+ N REPCNT,RESGRP,TEMPRESL,CNT
+ N DARRAY,DDATA,DDLG,DEND,DLOC,DMAP,DNAM,DNODE,DSEQ,DSTRT,DSUB,JND
+ ;
  K ^TMP("PXRMEXTMP",$J),^TMP("PXRMEXFND",$J)
 …
  .D DPARSE
  ;Scan dialog components in 120 and save dialog links
  S JND="B",REPCNT=0
+ S JND="B"
  F  S JND=$O(^PXD(811.8,IEN,120,IND,1,JND),-1) Q:'JND  D
  .S DDATA=$G(^PXD(811.8,IEN,120,IND,1,JND,0)) Q:DDATA=""
 …
  .F  S DSUB=$O(^PXD(811.8,IEN,100,DSUB)) Q:DSUB>DEND  D
  ..S DNODE=$G(^PXD(811.8,IEN,100,DSUB,0))
+ ..I ($P(DNODE,";")'="801.412")&($P(DNODE,";")'="801.41121")&($P(DNODE,";",3)'["118~") Q
+ ..S FILE=$P(DNODE,";")
+ ..I $P(DNODE,";")'="801.412"&($P(DNODE,";",3)'["118~") Q
  ..S DNODE=$P(DNODE,";",3)
  ..;;Modified Exchange to handle dialogs with replacement dialogs
 …
  ...S DNAM=$P(DNODE,"~",2) Q:DNAM=""
  ...S DLOC=$G(^TMP("PXRMEXTMP",$J,"DLOC",DNAM))
  ...S REPCNT=REPCNT+1,^TMP("PXRMEXTMP",$J,"DREPL",REPCNT,DDLG)=DNAM_U_DLOC
+ ...S ^TMP("PXRMEXTMP",$J,"DREPL",DDLG)=DNAM_U_DLOC
  ..I $E(DNODE,1,4)'=".01~" Q
  ..S DSEQ=$P(DNODE,"~",2) Q:DSEQ=""
+ ..I FILE="801.41121" D  Q
+ ...S DNAM=$P(DNODE,"~",2) Q:DNAM=""
+ ...S DLOC=$G(^TMP("PXRMEXTMP",$J,"DLOC",DNAM))
+ ...S CNT=0
+ ...I $D(^TMP("PXRMEXTMP",$J,"DMAP",DDLG))>0 S CNT=$O(^TMP("PXRMEXTMP",$J,"DMAP",DDLG,""),-1)
+ ...S ^TMP("PXRMEXTMP",$J,"DMAP",DDLG,CNT+1)=DNAM_U_DLOC
+ ..S DNODE=$G(^PXD(811.8,IEN,100,DSUB+1,0))
+ ..I ($P(DNODE,";")'="801.412") Q
+ ..S DNODE=$G(^PXD(811.8,IEN,100,DSUB+1,0)) I $P(DNODE,";")'="801.412" Q
  ..S DNODE=$P(DNODE,";",3) I $E(DNODE,1,2)'="2~" Q
  ..S DNAM=$P(DNODE,"~",2) Q:DNAM=""
 …
+ ;
  ;Build index of dialog findings by name
+ ;
+ ;
  N FDATA,FILENAM,FILENUM,FNAME
  S IND=0
 …
  ..;Save entry
  ..S ^TMP("PXRMEXFND",$J,FNAME)=FILENUM_U_FILENAM_U_IND
- I $D(TEMPRESL)>0 D
- .S DDLG="" F  S DDLG=$O(TEMPRESL(DDLG)) Q:DDLG=""  D
- ..;S ^TMP("PXRMEXTMP",$J,"RESULT",DDLG,TEMPRESL(DDLG))=""
- ..S DSEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",DDLG,""),-1)
- ..S ^TMP("PXRMEXTMP",$J,"DMAP",DDLG,DSEQ+1)=TEMPRESL(DDLG)_U_RESGRP(TEMPRESL(DDLG))
+ Q
+ ;
 …
+ ;
  ;Find where all the field numbers are kept
+ N DARRAY,DDATA,DFNUM,DRAW,DSTRING,RESNAM
+ S DSUB=DSTRT-1,DSTRING=";.01;4;5;15;24;25;55;"
+ ;S DSUB=DSTRT,DSTRING=";4;5;15;24;25;"
+ N DARRAY,DDATA,DFNUM,DRAW,DSTRING
+ S DSUB=DSTRT,DSTRING=";4;5;15;24;25;"
  F  S DSUB=$O(^PXD(811.8,IEN,100,DSUB)) Q:'DSUB  D  Q:DSUB>DEND
  .S DDATA=$G(^PXD(811.8,IEN,100,DSUB,0)) Q:DDATA=""
 …
  .S DFNUM=$P(DDATA,";",3),DFNUM=$P(DFNUM,"~") Q:DFNUM=""
  .I DSTRING[(";"_DFNUM_";") S DARRAY(DFNUM)=DSUB
- .I $P(DDATA,";")="801.41121" S DARRAY(55)=DSUB
+ ;
  ;Determine dialog component type
  S DSUB=DARRAY(4) Q:'DSUB
  S DTYP=$P($G(^PXD(811.8,IEN,100,DSUB,0)),"~",2)
  I DTYP'["result" S:DTYP[" " DTYP=$P(DTYP," ",2) S:DTYP="value" DTYP="forced"
+ S:DTYP[" " DTYP=$P(DTYP," ",2) S:DTYP="value" DTYP="forced"
+ ;
  ;Initialise text and finding fields
  S DTXT="*NONE*",DFIND=""
  ;Get text appropriate for the type of component
  I ((DTYP="element")!(DTYP="group"))&(DTYP'["result") D
+ I (DTYP="element")!(DTYP="group") D
  .;search for WP text
  .S DSUB=$G(DARRAY(25)) D:DSUB
 …
  ..;Reformat text to 50 characters
  ..D DWP(.DTXT)
+ ..;Search for Result Group/Element
+ ..S DSUB=$G(DARRAY(55)) I DSUB>0 D
+ ...S RESNAME=$P($P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3),"~",2)
+ ...S TEMPRESL(DNAM)=RESNAME
+ .;
  .;Search for finding item
  .S DSUB=$G(DARRAY(15)) D:DSUB
 …
  ...I $P(DFNAM,".")="ICD9" S DFNAM=$P(DFNAM," ")
  ...S DCNT=DCNT+1,DFIAD(DCNT)=DFNAM
+ ;
- I DTYP["result" D
- .S DSUB=$G(DARRAY(.01)) Q:'DSUB
- .S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT=""
- .S DTXT=$P(DTEXT,"~",2)
- .S RESGRP(DNAM)=DSTRT_U_DEND_U_IND_U_JND
+ ;
  I DTYP="prompt" D

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLC.m

-              r628
+              r636
 PXRMEXLC ; SLC/PKR/PJH - Routines to display repository entry components. ;08/03/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMEXLC ; SLC/PKR/PJH - Routines to display repository entry components. ;06/22/2004
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;======================================================
 BLDLIST(FORCE) ;Build a list of all repository entries.
 …
  I $D(^TMP("PXRMEXLR",$J,"VALMCNT")) S VALMCNT=^TMP("PXRMEXLR",$J,"VALMCNT")
  E  D
+ . D REXL^PXRMLIST("PXRMEXLR")
+ . S VALMCNT=^TMP("PXRMEXLR",$J,"VALMCNT")
+ . N IEN,RELIST
+ . D RE^PXRMLIST(.RELIST,.IEN)
+ . M ^TMP("PXRMEXLR",$J)=RELIST
+ . S VALMCNT=RELIST("VALMCNT")
+ . F IND=1:1:VALMCNT S ^TMP("PXRMEXLR",$J,"IDX",IND,IND)=IEN(IND)
+ Q
+ ;
 …
+ ;
  ;======================================================
+DDISP(IND,NITEMS,FILENUM) ;Setup dialog display list.
+ N JND,NLINE,NSEL,TEMP
+ S (NLINE,NSEL)=0
+ F JND=1:1:NITEMS D
+ . S TEMP=^PXD(811.8,IEN,120,IND,1,JND,0)
+ . S PT01=$P(TEMP,U,1)
+ . S EXISTS=$$EXISTS^PXRMEXIU(FILENUM,PT01,"W")
+ . S NLINE=NLINE+1
+ . S NSEL=NSEL+1
+ . S ^TMP("PXRMEXLD",$J,NLINE,0)=$$FMTDATA(NSEL,PT01,CAT,EXISTS)
+ . S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ .;Store the file number, start and stop line in the repository.
+ . S ^TMP("PXRMEXLD",$J,"SEL",NSEL)=FILENUM_U_$P(TEMP,U,2,3)
+ Q
+ ;
+ ;======================================================
 FMTDATA(NSEL,PT01,CAT,EXISTS) ;Format items for display.
  N NSTI,TEMP
 …
+ ;
  ;======================================================
+HISTLIST(LIST,VALMCNT) ;Build a list of install histories in
+ ;^TMP("PXRMEXIH",$J).
+ N DATE,DC,ENTRY,IHIND,IND,INDONE,NLINE,NSEL,RIEN,SOURCE,TEMP,USER
+ K ^TMP("PXRMEXIH",$J)
+ S (NLINE,NSEL)=0
+ S IND=""
+ F  S IND=$O(LIST(IND)) Q:IND=""  D
+ . S RIEN=^TMP("PXRMEXLR",$J,"IDX",IND,IND)
+ . I $D(^PXD(811.8,RIEN,130)) S INDONE=1
+ . E  S INDONE=0
+ . S TEMP=^PXD(811.8,RIEN,0)
+ . S ENTRY=$P(TEMP,U,1)
+ . S SOURCE=$P(TEMP,U,2)
+ . S DATE=$P(TEMP,U,3)
+ . S NLINE=NLINE+1
+ . I INDONE S NSEL=NSEL+1
+ . S ^TMP("PXRMEXIH",$J,NLINE,0)=$$FRE^PXRMLIST(" ",ENTRY,SOURCE,DATE)
+ . I INDONE S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXIH",$J,NLINE,0)="     Installation Date       Installed By"
+ . I INDONE S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXIH",$J,NLINE,0)="     -----------------       ------------"
+ . I INDONE S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ . I 'INDONE D  Q
+ .. S NLINE=NLINE+1
+ .. S ^TMP("PXRMEXIH",$J,NLINE,0)="      none"
+ .. S NLINE=NLINE+1
+ .. S ^TMP("PXRMEXIH",$J,NLINE,0)=" "
+ . S DATE="",DC=0
+ . F  S DATE=$O(^PXD(811.8,RIEN,130,"B",DATE)) Q:DATE=""  D
+ .. S NLINE=NLINE+1
+ .. S DC=DC+1
+ .. I DC>1 S NSEL=NSEL+1
+ .. S IHIND=$O(^PXD(811.8,RIEN,130,"B",DATE,""))
+ .. S TEMP=^PXD(811.8,RIEN,130,IHIND,0)
+ .. S ^TMP("PXRMEXIH",$J,NLINE,0)=$$RJ^XLFSTR(NSEL,4," ")_" "_$$FMTE^XLFDT($P(TEMP,U,1),"5Z")_"   "_$P(TEMP,U,2)
+ .. S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ .. S ^TMP("PXRMEXIH",$J,"SEL",NSEL)=RIEN_U_IHIND
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXIH",$J,NLINE,0)=" "
+ . S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ S VALMCNT=NLINE
+ Q
+ ;
+ ;======================================================
 INSCHR(NUM,CHR) ;Return a string of NUM characters (CHR).
  N IND,TEMP
 …
+ ;
  ;======================================================
+ORDER(STRING,ORDER) ;Rebuild string in ascending or descending order.
+ N ARRAY,ITEM,CNT
+ F CNT=1:1 S ITEM=$P(STRING,",",CNT) Q:'ITEM  S ARRAY(ITEM)=""
+ K STRING
+ F CNT=1:1 S ITEM=$O(ARRAY(ITEM),ORDER) Q:'ITEM  D
+ .S $P(STRING,",",CNT)=ITEM
+DREPL ;
+ N STR,I
+ K PXRMEXOR
+ S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ S STR="" F I=1:1:30 S STR=STR_"-"
+ S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J(STR_" REPLACEMENT ITEMS "_STR,79)
+DREPL1 ;
+ M ^TMP($J,"PXRMEXREP")=PXRMEXRP
+ K PXRMEXRP
+ ;S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)="
+ N CNT,DLG,DDATA,DDLG,DEND,DNAM,DREP,DSTRT,IND,JND,LEV,TEMP
+ ;S LEV="" F  S LEV=$O(^TMP($J,"PXRMEXREP",LEV)) Q:LEV=""  D
+ S LEV=0
+ S DLG="" F  S DLG=$O(^TMP($J,"PXRMEXREP",DLG)) Q:DLG=""  D
+ .S DDATA=$G(^TMP("PXRMEXTMP",$J,"DREPL",DLG)) Q:DDATA=""
+ .S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) Q:DNAM=""
+ .I $D(PXRMEXOR(DNAM))>0 Q
+ .S PXRMEXOR(DNAM)=""
+ .S IND=$P(DDATA,U,4),JND=$P(DDATA,U,5)
+ .;Check if this component has been replaced
+ .S LEV=LEV+1
+ .S DREP=$G(PXRMNMCH(FILENUM,DNAM)) I DREP=DNAM S DREP=""
+ .;Save line in workfile
+ .S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ .S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ .D DLINE^PXRMEXLD(DNAM,LEV,"")
+ .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAM)) D DCMP^PXRMEXLD(DNAM,LEV)
+ K ^TMP($J,"PXRMEXREP")
+ I $D(PXRMEXRP)>0 D DREPL1
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLD.m

-              r628
+              r636
+PXRMEXLD ;SLC/PJH - Reminder Dialog Exchange Main Routine. ;08/07/2007
+ ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;
+PXRMEXLD ;SLC/PJH - Reminder Dialog Exchange Main Routine. ;7/01/2004
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;=====================================================================
 START N PXRMBG,PXRMMODE,VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ
  S X="IORESET"
  D EN^VALM("PXRM EX LIST DIALOG")
+ ;
  ;Rebuild Display
  D CDISP^PXRMEXLC(PXRMRIEN)
+ Q
+ ;
+ENTRY ; Entry point for List Manager
+ D FIND Q
+ ;
+DETAIL ;Detailed display
+ S PXRMMODE=0 D DISP(PXRMMODE) Q
+ ;
+FIND ;Display findings
+ S PXRMMODE=2 D DISP(PXRMMODE) Q
+ ;
+SUM ;Display dialog summary
+ S PXRMMODE=3 D DISP(PXRMMODE) Q
+ ;
+USE ;Display dialog usage
+ S PXRMMODE=4 D DISP(PXRMMODE) Q
+ ;
+TEXT ;Display dialog text
+ S PXRMMODE=1 D DISP(PXRMMODE) Q
+ ;
+EXIT ;
+ENTRY D FIND Q
+ ;
+DETAIL S PXRMMODE=0 D DISP(PXRMMODE) Q
+ ;
+ ;Display Findings
+ ;--------------------------
+FIND S PXRMMODE=2 D DISP(PXRMMODE) Q
+ ;
+ ;Display Dialog Summary
+ ;----------------------
+SUM S PXRMMODE=3 D DISP(PXRMMODE) Q
+ ;
+ ;Display Dialog Usage
+ ;--------------------
+USE S PXRMMODE=4 D DISP(PXRMMODE) Q
+ ;
+ ;Display Dialog Text
+ ;-------------------
+TEXT S PXRMMODE=1 D DISP(PXRMMODE) Q
+ ;
+EXIT K ^TMP("PXRMEXLD",$J) Q
+ ;
+PEXIT ;PXRM EXCH DIALOG MENU protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ ;Reset after page up/down etc
+ D XQORM
+ Q
+ ;
+HELP N ORU,ORUPRMT,XQORM,PXRMTAG S PXRMTAG="DLG"
+ D EN^VALM("PXRM EX DIALOG HELP")
+ Q
+ ;
+HDR S VALMHDR(1)="Packed reminder dialog: "
+ S VALMHDR(1)=VALMHDR(1)_$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM"))
+ I $D(^TMP("PXRMEXTMP",$J,"PXRMDNAT")) D
+ .S VALMHDR(1)=VALMHDR(1)_" [NATIONAL DIALOG]"
+ S VALMHDR("TITLE")=VALMHDR(1)
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+ ;Build list manager workfile from ^TMP("PXRMEXTMP" (see ^PXRMEXLB)
+DISP(VIEW) ;
+ N OLEV,ODSEQ
  K ^TMP("PXRMEXLD",$J)
+ Q
+ ;
+DISP(VIEW) ;Build the requested view and display it.
+ D BLDDISP^PXRMEXD1(VIEW)
+ K PXRMEXRP
+ K ^TMP($J,"PXRMEXREP")
+ N DDATA,DDLG,DEND,DREP,DSTRT,IND,JND,NLINE,NSEL
+ S NLINE=0,NSEL=0,VALMBCK="R",VALMCNT=NLINE
+ S DDLG=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM")) Q:DDLG=""
+ ;
+ ;Save reminder dialog
+ S DDATA=^TMP("PXRMEXTMP",$J,"DLOC",DDLG)
+ S DSTRT=$P(DDATA,U,1),DEND=$P(DDATA,U,2)
+ S IND=$P(DDATA,U,3),JND=$P(DDATA,U,4),DREP=""
+ D DLINE(DDLG,"","")
+ S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ;Process componentS
+ D DCMP(DDLG,"")
+ ;Process replacement elements
+ ;I $D(^TMP("PXRMEXTMP",$J,"DREPL"))>0 D DREPL^PXRMEXLC
+ I $D(PXRMEXRP)>0 D DREPL^PXRMEXLC
  ;Change header
  I VIEW=0 D CHGCAP^VALM("HEADER2","Dialog Details")
 …
  I VIEW=3 D CHGCAP^VALM("HEADER2","Dialog Summary")
  I VIEW=4 D CHGCAP^VALM("HEADER2","Dialog Usage")
+ S VALMCNT=^TMP("PXRMEXLD",$J,"VALMCNT"),VALMBG=1,VALMBCK="R"
+ ;
+ S VALMCNT=NLINE,^TMP("PXRMEXLD",$J,"VALMCNT")=VALMCNT,VALMBG=1
+ ;
+ K ^TMP($J,"PXRMEXREP"),PXRMEXRP
  ;Reset protocol
  D XQORM
+ Q
+ ;
+HELP ;
+ N ORU,ORUPRMT,XQORM,PXRMTAG
+ S PXRMTAG="DLG"
+ D EN^VALM("PXRM EX DIALOG HELP")
+ Q
+ ;
+HDR ;
+ S VALMHDR(1)="Packed reminder dialog: "
+ S VALMHDR(1)=VALMHDR(1)_$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM"))
+ I $D(^TMP("PXRMEXTMP",$J,"PXRMDNAT")) S VALMHDR(1)=VALMHDR(1)_" [NATIONAL DIALOG]"
+ S VALMHDR("TITLE")=VALMHDR(1)
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+PEXIT ;PXRM EXCH DIALOG MENU protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ ;Reset after page up/down etc
+ D XQORM
+ Q
+ ;
+VALID(STRING) ;Validate sequence numbers
+ ;Update workfile
+DLINE(DNAM,LEV,DSEQ) ;
+ ;Check if standard PXRM prompt
+ N LEVSEQ,TLEV
+ N DPXRM S DPXRM=$$PXRM^PXRMEXID(DNAM)
+ ;
+ ;Ignore PXRM prompts if doing a finding view (DF)
+ I VIEW>1,DPXRM Q
+ ;
+ N DEXIST,DPTX,DTXT,DTYP,EXIST,ITEM,TEMP,SEP
+ S ITEM=""
+ I DPXRM=0 S NSEL=NSEL+1,ITEM=NSEL
+ S NLINE=NLINE+1,SEP=$E(LEV,$L(LEV)),DEXIST=0
+ S LEVSEQ=LEV_DSEQ
+ S TEMP=$J(ITEM,3)_$J("",4)_LEV_DSEQ
+ ;Determine type
+ S DTYP=$G(^TMP("PXRMEXTMP",$J,"DTYP",DNAM))
+ ;Dialog component display
+ I (VIEW'=1) D
+ .I $L(TEMP)<13 S TEMP=TEMP_$J("",12+$L(SEP)-$L(TEMP))_$E(DNAM,1,50)
+ .E  S TEMP=TEMP_" "_$E(DNAM,1,50)
+ I VIEW=1 D
+ .I DTYP]"" S DTXT=$G(^TMP("PXRMEXTMP",$J,"DTXT",DNAM))
+ .I DTYP="" S DTXT=DNAM
+ .I DREP'="" S DTXT=DNAM
+ .I $L(TEMP)<13 S TEMP=TEMP_$J("",12+$L(SEP)-$L(TEMP))_$E(DTXT,1,50)
+ .E  S TEMP=TEMP_" "_$E(DTXT,1,50)
+ ;Check for replacements
+ I $D(^TMP("PXRMEXTMP",$J,"DREPL",DNAM))>0 D
+ .S TEMP=TEMP_"*"
+ .S TLEV=$S($E(LEVSEQ,$L(LEVSEQ))=".":$E(LEVSEQ,1,$L(LEVSEQ)-1),1:LEVSEQ)
+ .S PXRMEXRP(DNAM)=""
+ .;S ^TMP($J,"PXRMEXREP",TLEV,DNAM)=""
+ ;Add Type
+ S TEMP=TEMP_$J("",65-$L(TEMP))_DTYP
+ ;Exists flag
+ I DPXRM=0,$$EXISTS^PXRMEXIU(801.41,DNAM) D
+ .S TEMP=TEMP_$J("",75-$L(TEMP))_"X",DEXIST=1
+ S ^TMP("PXRMEXLD",$J,NLINE,0)=TEMP
+ ;
+ ;Set up selection index
+ S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)="" Q:DPXRM=1
+ ;Store the file number, start and stop line in the exchange file.
+ S ^TMP("PXRMEXLD",$J,"SEL",NSEL)=FILENUM_U_DSTRT_U_DEND_U_DEXIST_U_IND_U_JND
+ ;Insert additional text lines
+ I VIEW=1,DREP="" D
+ .N DSUB,DTXT,FILENUM
+ .S DSUB=0,FILENUM=8927.1
+ .F  S DSUB=$O(^TMP("PXRMEXTMP",$J,"DTXT",DNAM,DSUB)) Q:'DSUB  D
+ ..S DTXT=$G(^TMP("PXRMEXTMP",$J,"DTXT",DNAM,DSUB)),NLINE=NLINE+1
+ ..S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",12+$L(SEP))_$E(DTXT,1,50)
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ .;TIU template changes
+ .I $D(PXRMNMCH(FILENUM)),$D(^TMP("PXRMEXTMP",$J,"DTIU",DNAM)) D
+ ..N TEMP,TNAM,TNNAM
+ ..S TNAM=""
+ ..F  S TNAM=$O(^TMP("PXRMEXTMP",$J,"DTIU",DNAM,TNAM)) Q:TNAM=""  D
+ ...S TNNAM=$G(PXRMNMCH(FILENUM,TNAM)) Q:TNNAM=""
+ ...S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ...S TEMP=$J("",12+$L(SEP))_"(TIU template "_TNAM_" copied to "_TNNAM_")"
+ ...S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=TEMP
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ...S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ;Insert finding items
+ I VIEW=2,("element;group"[DTYP),DREP="" D
+ .N DSUB,FDATA,FILENUM,FLIT,FLONG,FNAME,FOUND,FREP,FTAB,FTYP,TEMP
+ .;Findings and additional findings
+ .S DSUB=0,FOUND=0
+ .F  S DSUB=$O(^TMP("PXRMEXTMP",$J,"DFND",DNAM,DSUB)) Q:'DSUB  D
+ ..S FNAME=$G(^TMP("PXRMEXTMP",$J,"DFND",DNAM,DSUB)) Q:FNAME=""
+ ..S FDATA=$G(^TMP("PXRMEXFND",$J,FNAME))
+ ..S FILENUM=$P(FDATA,U),FTYP=$P(FDATA,U,2) Q:'FILENUM
+ ..S FREP=$G(PXRMNMCH(FILENUM,FNAME)) I FREP=FNAME S FREP=""
+ ..S NLINE=NLINE+1,EXIST=$$EXISTS^PXRMEXIU(FILENUM,FNAME),FOUND=1
+ ..I DSUB=1 S FLIT="Finding: "
+ ..I DSUB>1 S FLIT="Add. Finding: "
+ ..S FLONG=0 I $L(FLIT_FNAME_" ("_FTYP_")")>60 S FLONG=1
+ ..I 'FLONG S FNAME=FLIT_FNAME_" ("_FTYP_")"
+ ..I FLONG S FNAME=FLIT_FNAME
+ ..S TEMP=$J("",12+$L(SEP))_$E(FNAME,1,60)_$J("",60-$L(FNAME))
+ ..I EXIST S TEMP=TEMP_$J("",75-$L(TEMP))_"X"
+ ..S ^TMP("PXRMEXLD",$J,NLINE,0)=TEMP
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ..I FLONG D
+ ...S NLINE=NLINE+1
+ ...S FTAB=$S(DSUB=1:21,1:26)
+ ...S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",FTAB)_"("_FTYP_")"
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ..I FREP'="" D
+ ...S NLINE=NLINE+1
+ ...S FTAB=$S(DSUB=1:21,1:26)
+ ...S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",FTAB)_"(Replaced by "_FREP_")"
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ .;If no findings
+ .I 'FOUND D
+ ..S NLINE=NLINE+1
+ ..S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",12+$L(SEP))_"Finding: *NONE*"
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ;
+ ;Usage screen
+ I VIEW=4,DREP="" D
+ .N DOTHER,DTXT,DTYPE,OTHER,TYPE
+ .D OTHER(DNAM,.DOTHER) Q:'$D(DOTHER)
+ .S OTHER=""
+ .F  S OTHER=$O(DOTHER(OTHER)) Q:OTHER=""  D
+ ..S TYPE=DOTHER(OTHER),NLINE=NLINE+1,DTYPE="REMINDER DIALOG"
+ ..I TYPE="G" S DTYPE="DIALOG GROUP"
+ ..I TYPE="E" S DTYPE="DIALOG ELEMENT"
+ ..S DTXT="USED BY: "_OTHER_" ("_DTYPE_")"
+ ..S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",12+$L(SEP))_DTXT
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ Q
+ ;
+ ;Save details of dialog components for display
+DCMP(DLG,LEV) ;
+ N DDATA,DDLG,DEND,DNAM,DSEQ,DSTRT,IND,JND,LAST,LEVSEQ,NUM
+ S DSEQ=0,LAST=0
+ F  S DSEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",DLG,DSEQ)) Q:'DSEQ  D
+ .S DDATA=^TMP("PXRMEXTMP",$J,"DMAP",DLG,DSEQ)
+ .S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) Q:DNAM=""
+ .S IND=$P(DDATA,U,4),JND=$P(DDATA,U,5)
+ .;Check if this component has been replaced
+ .S DREP=$G(PXRMNMCH(FILENUM,DNAM)) I DREP=DNAM S DREP=""
+ .;Save line in workfile
+ .S NUM=DSEQ
+ .;S NUM=$S($G(REPL)["R":"."_DSEQ,1:DSEQ)
+ .I +LEV>0,NUM>0,$E(LEV,$L(LEV))'="." S LEV=LEV_"."
+ .D DLINE(DNAM,LEV,NUM) Q:DREP'=""
+ .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAM)) D DCMP(DNAM,LEV_DSEQ_".")
+ .;Extra line feed
+ .I LEV="" D
+ ..S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ I $G(REPL)["R" D
+ .S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ .S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ Q
+ ;
+ ;Rebuild string in ascending or descending order
+ORDER(STRING,ORDER) ;
+ N ARRAY,ITEM,CNT
+ F CNT=1:1 S ITEM=$P(STRING,",",CNT) Q:'ITEM  S ARRAY(ITEM)=""
+ K STRING
+ F CNT=1:1 S ITEM=$O(ARRAY(ITEM),ORDER) Q:'ITEM  D
+ .S $P(STRING,",",CNT)=ITEM
+ Q
+ ;
+ ;Check if used by other dialogs
+OTHER(NAME,LIST) ;
+ N DDATA,DIEN,DNAME,DTYP,IEN
+ S IEN=$O(^PXRMD(801.41,"B",NAME,0)) Q:'IEN
+ ;Check if used by other dialogs
+ I '$D(^PXRMD(801.41,"AD",IEN)) Q
+ ;Build list of dialogs using this component
+ S DIEN=0
+ F  S DIEN=$O(^PXRMD(801.41,"AD",IEN,DIEN)) Q:'DIEN  D
+ .S DDATA=$G(^PXRMD(801.41,DIEN,0)) Q:DDATA=""
+ .S DNAME=$P(DDATA,U),DTYP=$P(DDATA,U,4) Q:DNAME=""
+ .;Include only dialogs that are not part of this reminder dialog
+ .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) Q
+ .S LIST(DNAME)=DTYP
+ Q
+ ;
+ ;Validate sequence numbers
+VALID(STRING) ;
  N CNT,FOUND,OK
  S FOUND=0,OK=1
 …
+ ;
  ;Sort the SELECTION into reverse order
  D ORDER^PXRMEXLC(.SELECT,-1)
+ D ORDER(.SELECT,-1)
+ ;
  ;Lock the file
 …
  D UNLOCK^PXRMEXID
+ ;
+ ;
  ;Rebuild Workfile
  D DISP^PXRMEXLD(PXRMMODE)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLI.m

-              r628
+              r636
 PXRMEXLI ; SLC/PKR - List Manager routines for repository entry install. ;08/08/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXLI ; SLC/PKR - List Manager routines for repository entry install. ;01/10/2003
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;================================================
 INSALL ;Install all components in a repository entry.
  N IND,INSTALL
+ K ^TMP("PXRMEXIA",$J)
+ ;Set the install date and time.
+ S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
  ;Initialize the name change storage.
  K PXRMNMCH
 …
  I FILENUM=0 D
  . D RTNLD^PXRMEXIC(PXRMRIEN,START,END,.ATTR,.RTN)
- . D CHECKSUM^PXRMEXCS(.ATTR,START,END)
  . S ACTION=$$GETRACT^PXRMEXCF(.ATTR,.NEWNAME,.PXRMNMCH,.RTN,EXISTS)
  .;Save what was done for the installation summary.
 …
  . I FIELDNUM=.001 S TEMP=^PXD(811.8,PXRMRIEN,100,(START+1),0)
  . S PT01=$P(TEMP,"~",2)
+ . D SETATTR^PXRMEXFI(.ATTR,FILENUM,PT01)
+ . D CHECKSUM^PXRMEXCS(.ATTR,START,END)
+ . D SETATTR^PXRMEXFI(.ATTR,FILENUM)
  . S ACTION=$$GETFACT^PXRMEXFI(PT01,.ATTR,.NEWPT01,.PXRMNMCH,EXISTS)
  .;Save what was done for the installation summary.
 …
  I '$D(VALMY) Q
+ ;
+ K ^TMP("PXRMEXIA",$J)
+ ;Set the install date and time.
+ S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
+ ;
  ;Initialize the name change storage.
  K PXRMNMCH
  S (IND,INSTALL)=0
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D INSCOM(IND,.INSTALL)
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .D INSCOM(IND,.INSTALL)
+ ;
  ;If anything was installed rebuild the display.
 …
  I '$D(^PXD(811.8,PXRMRIEN,120)) D CLIST^PXRMEXU1(.PXRMRIEN)
  I PXRMRIEN=-1 Q
- K ^TMP("PXRMEXIA",$J),^TMP("PXRMEXIAD",$J)
- ;Set the install date and time and type.
- S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
- S ^TMP("PXRMEXIA",$J,"TYPE")="INTERACTIVE"
  ;Format the component list for display.
  D CDISP^PXRMEXLC(PXRMRIEN)
 …
+ Q
+ ;
- ;================================================
  ;Exit action added to PXRM EXCH INSTALL MENU
 PEXIT ;PXRM EXCH INSTALL MENU protocol exit code
 …
+ Q
+ ;
- ;================================================
 XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT COMPONENT",0))_U_"1:"_VALMCNT
  S XQORM("A")="Select Action: "
+ Q
+ ;
- ;================================================
 XSEL ;PXRM EXCH SELECT COMPONENT validation
  N CNT,SELECT,SEL,PXRMDONE
 …
+ ;
  ;Sort selections into ascending sequence order
  D ORDER^PXRMEXLC(.SELECT,1)
+ D ORDER^PXRMEXLD(.SELECT,1)
+ ;
  K ^TMP("PXRMEXIA",$J),^TMP("PXRMEXIAD",$J)
  ;Set the install date and time and type.
+ K ^TMP("PXRMEXIA",$J)
+ ;Set the install date and time.
  S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
- S ^TMP("PXRMEXIA",$J,"TYPE")="INTERACTIVE"
+ ;
  ;Install selected component

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLM.m

-              r628
+              r636
 PXRMEXLM ; SLC/PKR/PJH - Clinical Reminder Exchange List Manager routines. ;10/11/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMEXLM ; SLC/PKR/PJH - Clinical Reminder Exchange List Manager routines. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;=====================================================
 …
+ ;
  ;=====================================================
+EN ;Main entry point for PXRM EXCHANGE
+ N PXRMDONE,PXRMNMCH
+ ;PXRMDONE is set to true if the user enters an action of Quit.
+ S PXRMDONE=0
+ ;PXRMNMCH is used to store name change information. If a finding
+ ;is copied to a new name or is replaced by another finding the
+ ;information is stored here. It is used when installing definitions
+ ;or dialogs so they use the new or replaced finding.
+ N VALMBCK,VALMSG,X,XMZ
+ S X="IORESET"
+ D ENDR^%ZISS
+ D BLDLIST^PXRMEXLC(0)
+ D EN^VALM("PXRM EX REMINDER EXCHANGE")
+ W IORESET
+ D KILL^%ZISS
+ Q
+ ;
+ ;=====================================================
 ENTRY ;Entry code
- D BLDLIST^PXRMEXLC(0)
  D XQORM
+ Q
 …
  K ^TMP("PXRMEXFND",$J)
  K ^TMP("PXRMEXIA",$J)
- K ^TMP("PXRMEXIAD",$J)
  K ^TMP("PXRMEXID",$J)
  K ^TMP("PXRMEXIH",$J)
 …
+ Q
+ ;
- ;=====================================================
-START ;Main entry point for PXRM EXCHANGE
- N PXRMDONE,PXRMNMCH
- ;PXRMDONE is set to true if the user enters an action of Quit.
- S PXRMDONE=0
- ;PXRMNMCH is used to store name change information. If a finding
- ;is copied to a new name or is replaced by another finding the
- ;information is stored here. It is used when installing definitions
- ;or dialogs so they use the new or replaced finding.
- N VALMBCK,VALMSG,X,XMZ
- S X="IORESET"
- D ENDR^%ZISS
- D EN^VALM("PXRM EX REMINDER EXCHANGE")
- W IORESET
- D KILL^%ZISS
+ Q
+ ;
- ;=====================================================
 XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT ENTRY",0))_U_"1:"_VALMCNT
  S XQORM("A")="Select Action: "
+ Q
+ ;
- ;=====================================================
 XSEL ;PXRM EXCH SELECT COMPONENT validation
  N SEL,PXRMRIEN
 …
  .W $C(7),!,"Only one item number allowed." H 2
  .S VALMBCK="R"
  I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
  .W $C(7),!,SEL_" is not a valid item number." H 2
  .S VALMBCK="R"
+ ;
  ;Get the repository ien.
  S PXRMRIEN=^TMP("PXRMEXLR",$J,"SEL",SEL)
+ S PXRMRIEN=^TMP("PXRMEXLR",$J,"IDX",SEL,SEL)
+ ;
  ;Full screen mode
 …
  .;Rebuild the list for List Manager to display.
  .K ^TMP("PXRMEXLR",$J)
+ .D REXL^PXRMLIST("PXRMEXLR")
+ .S VALMCNT=^TMP("PXRMEXLR",$J,"VALMCNT")
+ .D RE^PXRMLIST(.RELIST,.IEN)
+ .M ^TMP("PXRMEXLR",$J)=RELIST
+ .S VALMCNT=RELIST("VALMCNT")
+ .F IND=1:1:VALMCNT D
+ ..S ^TMP("PXRMEXLR",$J,"IDX",IND,IND)=IEN(IND)
+ .;
  .S VALMHDR(1)="Deleted 1 exchange file entry",VALMHDR(2)=" ",VALMBCK="R"
+ ;
+ I OPTION="IH" D START^PXRMEXIH
+ ;
+ S VALMBCK="R"
+ Q
+ I OPTION="IH" D
+ .N HISLIST,VALMCNT
+ .S HISLIST(SEL)=""
+ .D HISTLIST^PXRMEXLC(.HISLIST,.VALMCNT)
+ .D EN^VALM("PXRM EX INSTALLATION HISTORY")
+ .K ^TMP("PXRMEXIH",$J)
+ ;
+ S VALMBCK="R"
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLR.m

-              r628
+              r636
 PXRMEXLR ; SLC/PKR/PJH - List Manager routines for existing repository entries. ;07/30/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXLR ; SLC/PKR/PJH - List Manager routines for existing repository entries. ;01/10/2003
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;==================================================
 CHF ;Create a host file containing repository entries.
 …
  ;Rebuild the list for List Manager to display.
  K ^TMP("PXRMEXLR",$J)
+ D REXL^PXRMLIST("PXRMEXLR")
+ D RE^PXRMLIST(.RELIST,.IEN)
+ M ^TMP("PXRMEXLR",$J)=RELIST
+ S VALMCNT=RELIST("VALMCNT")
+ F IND=1:1:VALMCNT S ^TMP("PXRMEXLR",$J,"IDX",IND,IND)=IEN(IND)
+ ;
  S VALMHDR(1)="Deleted "_DELLIST("COUNT")_" Exchange File"
 …
+ ;
  ;==================================================
+DELHIST ;Get a list of repository installation entries and delete them.
+ ;Save the original list, it contains the selected repository entries.
+ N VALMYO
+ M VALMYO=VALMY
+ N IHIND,IND,RIEN,TEMP,VALMY
+ N VALMBG,VALMLST
+ ;
+ S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXIH",$J,"IDX",""),-1)
+ ;Get the list to delete.
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:IND=""  D
+ . S TEMP=^TMP("PXRMEXIH",$J,"SEL",IND)
+ . S RIEN=$P(TEMP,U,1)
+ . S IHIND=$P(TEMP,U,2)
+ . D DELHIST^PXRMEXU1(RIEN,IHIND)
+ ;Rebuild the display list.
+ D HISTLIST^PXRMEXLC(.VALMYO,.VALMCNT)
+ S VALMBCK="R"
+ Q
+ ;
+ ;==================================================
 EXIT ; Exit code
  D CLEAN^VALM10
 …
+ ;
  ;==================================================
+IH ;Get a list of repository entries and show their installation history.
+ N VALMCNT,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;Build a history list.
+ D HISTLIST^PXRMEXLC(.VALMY,.VALMCNT)
+ D EN^VALM("PXRM EX INSTALLATION HISTORY")
+ K ^TMP("PXRMEXIH",$J)
+ S VALMBCK="R"
+ Q
+ ;
+ ;==================================================
+INDETAIL ;Output the details of an installation.
+ N VALMBG,VALMCNT,VALMHDR,VALMLST,VALMY
+ S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXIH",$J,"IDX",""),-1)
+ ;Get the list to display.
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ D INDISP(.VALMY)
+ Q
+ ;
+ ;==================================================
+INDISP(ARRAY) ;Display details list
+ N ACTION,CMPNT,DI,DP,ENTRY,IHIND,IND,INDEX,JND,KND
+ N NAME,NEWNAME,NLINE,RIEN,TEMP
+ K ^TMP("PXRMEXID",$J)
+ ;If there are no items then quit.
+ I '$D(ARRAY) Q
+ S (IND,NLINE)=0
+ F  S IND=$O(ARRAY(IND)) Q:IND=""  D
+ . S TEMP=^TMP("PXRMEXIH",$J,"SEL",IND)
+ . S RIEN=$P(TEMP,U,1)
+ . S IHIND=$P(TEMP,U,2)
+ . S TEMP=^PXD(811.8,RIEN,0)
+ . S ENTRY=$E($P(TEMP,U,1),1,38)
+ . S ENTRY=$$LJ^XLFSTR(ENTRY,38," ")
+ . S DP=$$FMTE^XLFDT($P(TEMP,U,3),"5Z")
+ . S DI=$$FMTE^XLFDT(^PXD(811.8,RIEN,130,IHIND,0),"5Z")
+ . I NLINE>1 D
+ .. S NLINE=NLINE+1
+ .. S ^TMP("PXRMEXID",$J,NLINE,0)="------------------------------------------------------------------------------"
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXID",$J,NLINE,0)=ENTRY_" "_DP_"  "_DI
+ .;Write the header line here.
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXID",$J,NLINE,0)="     Component                         Action  New Name"
+ . S CMPNT=""
+ . S JND=0
+ . F  S JND=$O(^PXD(811.8,RIEN,130,IHIND,1,JND)) Q:JND=""  D
+ .. S TEMP=^PXD(811.8,RIEN,130,IHIND,1,JND,0)
+ .. I $P(TEMP,U,2)'=CMPNT D
+ ... S NLINE=NLINE+1
+ ... S ^TMP("PXRMEXID",$J,NLINE,0)=" "
+ ... S CMPNT=$P(TEMP,U,2)
+ ... S NLINE=NLINE+1
+ ... S ^TMP("PXRMEXID",$J,NLINE,0)=CMPNT
+ .. S INDEX=$$RJ^XLFSTR($P(TEMP,U,1),4," ")
+ .. S NAME=$E($P(TEMP,U,3),1,36)
+ .. S NAME=$$LJ^XLFSTR(NAME,36," ")
+ .. S ACTION=$P(TEMP,U,4)
+ .. S NEWNAME=$E($P(TEMP,U,5),1,36)
+ .. S NEWNAME=$$LJ^XLFSTR(NEWNAME,36," ")
+ .. S NLINE=NLINE+1
+ .. S ^TMP("PXRMEXID",$J,NLINE,0)=INDEX_" "_NAME_" "_ACTION_"    "_NEWNAME
+ ..;If there are Additional Details add them to the display.
+ .. S KND=0
+ .. F  S KND=$O(^PXD(811.8,RIEN,130,IHIND,1,JND,1,KND)) Q:KND=""  D
+ ... S NLINE=NLINE+1
+ ... S ^TMP("PXRMEXID",$J,NLINE,0)=^PXD(811.8,RIEN,130,IHIND,1,JND,1,KND,0)
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXID",$J,NLINE,0)=" "
+ S VALMHDR(1)=^PXD(811.8,RIEN,0)_"  "_^TMP("PXRMEXID",$J,1,0)
+ S VALMCNT=NLINE
+ D EN^VALM("PXRM EX INSTALLATION DETAIL")
+ K ^TMP("PXRMEXID",$J)
+ S VALMBCK="R"
+ Q
+ ;
+ ;==================================================
 INSTALL ;Get a list of repository entries and install them.
  N IND,PXRMRIEN,VALMY
 …
  F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
  .;Get the repository ien.
  . S PXRMRIEN=^TMP("PXRMEXLR",$J,"SEL",IND)
+ . S PXRMRIEN=^TMP("PXRMEXLR",$J,"IDX",IND,IND)
  .;The list template calls INSTALL^PXRMEXLI
  . D EN^VALM("PXRM EX LIST COMPONENTS")
 …
+ ;
  ;==================================================
+IS ;Get a list of packed reminders and print the installation summary.
+ N VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ Q
+ ;
+ ;==================================================
 MIENLIST(LIST) ;Get a list of List Manager repository entries and turn it
  ;into iens.
 …
  F  S IND=$O(VALMY(IND)) Q:+IND=0  D
  . S COUNT=COUNT+1
+ . ;S IEN=^TMP("PXRMEXLR",$J,"IDX",IND,IND)
+ . S IEN=^TMP("PXRMEXLR",$J,"SEL",IND)
+ . S IEN=^TMP("PXRMEXLR",$J,"IDX",IND,IND)
  . S LIST(IEN)=""
  S LIST("COUNT")=COUNT
 …
 PEXIT ;PXRM EXCH INSTALLATION MENU protocol exit code
  S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+ ;Reset after page up/down etc
+ D XQORM
+ Q
+ ;
+ ;==================================================
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT HISTORY",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Action: "
+ Q
+ ;
+ ;==================================================
+XSEL ;PXRM EXCH SELECT HISTORY validation
+ N ARRAY,CNT,SELECT,SEL
+ S SELECT=$P(XQORNOD(0),"=",2)
+ I '$$VALID^PXRMEXLD(SELECT) S VALMBCK="R" Q
+ ;Build array of selected items
+ F CNT=1:1 S SEL=$P(SELECT,",",CNT) Q:'SEL  D
+ .S ARRAY(SEL)=""
+ ;
+ ;Display Selected Histories
+ D INDISP(.ARRAY)
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXPR.m

-              r628
+              r636
 PXRMEXPR ; SLC/PKR/PJH - Routines to create packed reminder definitions. ;12/12/2006
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXPR ; SLC/PKR/PJH - Routines to create packed reminder definitions. ;02/25/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;===============================================================
 ADDFILE(FLIST,ROOT,FILENAME) ;Add a file to the list of finding files.
 …
  D GETSPON(811.9,RIEN,.SPONLIST)
  ;If there is a dialog add it.
  ;S DIEN=+$P($G(^PXD(811.9,RIEN,51)),U,1)
  ;I DIEN>0 D GETSPON(801.41,DIEN,.SPONLIST)
+ S DIEN=+$P($G(^PXD(811.9,RIEN,51)),U,1)
+ I DIEN>0 D GETSPON(801.41,DIEN,.SPONLIST)
  ;Go through the finding list to find additional sponsors.
  S IND=""
 …
  ;Save the source information
  I +RTP'>0 Q
  K ^TMP(TMPIND,$J),^TMP("PXRMEXCS",$J)
+ K ^TMP(TMPIND,$J)
  D PUTSRC(RTP,TMPIND)
+ ;
 …
  ;If a dialog exists for this reminder add it and its findings to the
  ;list. Also collect any embedded TIU objects or templates
  D DIALOG^PXRMEXDG(RIEN,.DLGLIST,.FINDLIST,.OBJLIST,.TEMLIST,.SPONLIST)
+ D DIALOG^PXRMEXDG(RIEN,.DLGLIST,.FINDLIST,.OBJLIST,.TEMLIST)
+ ;
  ;If there were education topics make sure subtopics are included.
 …
  S LOC=$$SITE^VASITE
  S ^TMP(TMPIND,$J,"SRC","REMINDER")=$P(RTP,U,2)
+ ;S ^TMP(TMPIND,$J,"SRC","USER")=$P(^VA(200,DUZ,0),U,1)
  S ^TMP(TMPIND,$J,"SRC","USER")=$$GET1^DIQ(200,DUZ,.01)
  S ^TMP(TMPIND,$J,"SRC","SITE")=$P(LOC,U,2)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m

-              r628
+              r636
 PXRMEXPU ; SLC/PKR - Utilities for packing and unpacking repository entries. ;09/10/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXPU ; SLC/PKR - Utilities for packing and unpacking repository entries. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;==================================================
 BTTABLE(DIQOUT,IENROOT,TTABLE) ;Build the DIQOUT to FDA iens translation table.
 …
  . S TTABLE(FILENUM,IENS)="+"_IENS
  E  D  Q
  . W !,"BTTABLE^PXRMEXPU - DIQOUT problem, do not have correct top level"
+ . W !,"BTTABLE^PXRMEXPU - DIQOUT problem do not have correct top level"
+ ;
  F  S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM=""  D
 …
  ... I '$D(TYPE(FILENUM,FIELD)) S TYPE(FILENUM,FIELD)=$$GET1^DID(FILENUM,FIELD,"","TYPE")
  ... S PTRTO=$S(TYPE(FILENUM,FIELD)="POINTER":$$GET1^DID(FILENUM,FIELD,"","POINTER"),1:"")
- ... ;Remove pointers to file 200.
- ... I PTRTO="VA(200," S DIQOUT(FILENUM,IENS,FIELD)="" Q
  ...;If the field's type is COMPUTED then don't transport it.
  ... I TYPE(FILENUM,FIELD)="COMPUTED" K DIQOUT(FILENUM,IENS,FIELD) Q
 …
  ;==================================================
 GDIQF(LIST,NUM,TMPIND,SERROR) ;Save file entries into ^TMP(TMPIND,$J).
  N CSUM,DIQOUT,IENROOT,IND,FIELD,FILENAME,IENS,MSG,PT01,TEMP
+ N DIQOUT,IENROOT,IND,FIELD,FILENAME,IENS,MSG,PT01,TEMP
  S ^TMP(TMPIND,$J,"NUMF")=NUM
  F IND=1:1:NUM D
 …
  . I $$FOKTI^PXRMEXFI(FILENUM) S FIELD="**"
  . E  S FIELD=.01
  . D GETS^DIQ(FILENUM,IEN,FIELD,"N","DIQOUT","MSG")
+ . D GETS^DIQ(FILENUM,IEN,FIELD,"","DIQOUT","MSG")
  . I $D(MSG) D  Q
  .. S SERROR=1,IND=NUM
 …
  .;Convert the iens to the FDA adding form.
  . D CONTOFDA(.DIQOUT,.IENROOT)
- . S CSUM=$$DIQOUTCS^PXRMEXCS(.DIQOUT)
- . S ^TMP("PXRMEXCS",$J,IND,FILENAME)=CSUM
  .;Load the converted DIQOUT into TMP.
  . M ^TMP(TMPIND,$J,IND,FILENAME)=DIQOUT
 …
  ;==================================================
 GRTN(LIST,NUM,TMPIND,SERROR) ;Save routines into ^TMP(TMPIND,$J).
  N DIF,IEN,IND,RA,TEMP,X,XCNP
+ N DIF,IEN,IND,TEMP,X,XCNP
  S ^TMP(TMPIND,$J,"NUMR")=NUM
  S X=""
 …
  . X ^%ZOSF("TEST")
  . I $T D
+ .. K RA
+ .. S DIF="RA("
+ .. S DIF="^TMP(TMPIND,$J,""ROUTINE"","""_X_""","
  .. S XCNP=0
  .. X ^%ZOSF("LOAD")
- .. S ^TMP("PXRMEXCS",$J,"ROUTINE",X)=$$ROUTINE^PXRMEXCS(.RA)
- .. M ^TMP(TMPIND,$J,"ROUTINE",X)=RA
  . E  D
  .. S SERROR=1
 …
+ ;
  ;==================================================
 RMEH(FILENUM,DIQOUT,NOSTUB) ;Clear the edit history from all reminder files.
+RMEH(FILENUM,DIQOUT) ;Clear the edit history from all reminder files.
  ;Leave a stub so it can be filled in when the file is installed.
  I (FILENUM<800)!(FILENUM>811.9) Q
  N IENS,SFN,TARGET
+ N IEN,SFN,TARGET
  ;Edit History is stored in node 110 for all files, get the
  ;subfile number.
 …
  F  S IENS=$O(DIQOUT(SFN,IENS)) Q:IENS=""  K DIQOUT(SFN,IENS)
  ;Create a stub for the install.
- I $G(NOSTUB) Q
  S IENS="1,"_$O(DIQOUT(FILENUM,""))
  S DIQOUT(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXSI.m

-              r628
+              r636
+PXRMEXSI ; SLC/PKR/PJH - Silent repository entry install. ;09/28/2007
+ ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXSI ; SLC/PKR/PJH - Silent repository entry install. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;===================================================
+BUILD ;Build list manager workfile from ^TMP("PXRMEXTMP" (see ^PXRMEXLB)
+ N DDATA,DDLG,IND,JND,NLINE,NSEL
+ S NLINE=0,NSEL=0
+ S DDLG=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM")) Q:DDLG=""
+ ;
+ ;Save reminder dialog
+ S DDATA=^TMP("PXRMEXTMP",$J,"DLOC",DDLG)
+ S IND=$P(DDATA,U,3),JND=$P(DDATA,U,4)
+ D DSAVE(DDLG,IND,JND)
+ ;
+ ;Process sub-components
+ I $D(^TMP("PXRMEXTMP",$J,"DREPL",DDLG))>0 D DREPL(DDLG)
+ D DCMP(DDLG)
+ Q
+ ;
+ ;===================================================
+DCMP(DLG) ;Search for dialog components
+ N DDLG,DEND,DNAM,DSEQ,DSTRT,IND,JND
+ S DSEQ=0
+ F  S DSEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",DLG,DSEQ)) Q:'DSEQ  D
+ . S DDATA=^TMP("PXRMEXTMP",$J,"DMAP",DLG,DSEQ)
+ . S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) Q:DNAM=""
+ . S IND=$P(DDATA,U,4),JND=$P(DDATA,U,5)
+ .;Save line in workfile
+ . D DSAVE(DNAM,IND,JND)
+ .;
+ . I $D(^TMP("PXRMEXTMP",$J,"DREPL",DNAM))>0 D DREPL(DNAM)
+ .;Process any sub-components
+ . I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAM)) D DCMP(DNAM)
+ Q
+ ;
+ ;===================================================
+DREPL(DLG,LEV) ;
+ N DDATA,DDLG,DEND,DNAM,DSEQ,DSTRT,IND,JND
+ S DDATA=^TMP("PXRMEXTMP",$J,"DREPL",DLG)
+ S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) Q:DNAM=""
+ S IND=$P(DDATA,U,4),JND=$P(DDATA,U,5)
+ ;Save line in workfile
+ D DSAVE(DNAM,IND,JND)
+ I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAM)) D DCMP(DNAM)
+ Q
+ ;===================================================
+DSAVE(DNAM,IND,JND) ;Update workfile
+ ;Ignore national prompts
+ I $$PXRM^PXRMEXID(DNAM) Q
+ N DEXIST
+ S NSEL=NSEL+1
+ ;Check if dialog exists
+ S DEXIST=$$EXISTS^PXRMEXIU(801.41,DNAM)
+ ;Store the file number, start and stop line in the exchange file.
+ S ^TMP("PXRMEXLD",$J,"SEL",NSEL)=FILENUM_U_IND_U_JND_U_DEXIST
+ Q
+ ;
  ;===================================================
 INITMPG ;Initialize ^TMP arrays.
- K ^TMP("PXRMEXFND",$J)
  K ^TMP("PXRMEXIA",$J)
- K ^TMP("PXRMEXIAD",$J)
  K ^TMP("PXRMEXLC",$J)
  K ^TMP("PXRMEXLD",$J)
 …
+ ;
  ;===================================================
+INSCOM(PXRMRIEN,ACTION,IND,TEMP,REMNAME,HISTSUB) ;Install component IND
+ ;of PXRMRIEN.
+ N ATTR,END,EXISTS,FILENUM,IND120,JND120,NAME
+ N PT01,RTN,SAME,START,TEXT
+INSCOM(PXRMRIEN,IND,TEMP,REMNAME) ;Install component IND of PXRMRIEN.
+ N ACTION,ATTR,END,EXISTS,FILENUM,IND120,JND120,NAME
+ N PT01,RTN,START
  S FILENUM=$P(TEMP,U,1),EXISTS=$P(TEMP,U,4)
  S IND120=$P(TEMP,U,2),JND120=$P(TEMP,U,3)
- I (IND120="")!(JND120="") Q
  S TEMP=^PXD(811.8,PXRMRIEN,120,IND120,1,JND120,0)
+ ;If the component does not exist then the action has to be "I".
+ ;If the component exists and the action is "I" change it to "O".
+ ;If the component exists and the action is "M" leave it "M".
+ ;If the component exists and the action is "O" leave it "O".
+ S ACTION=$S('EXISTS:"I",ACTION="I":"O",1:ACTION)
+ S SAME=0
+ I (FILENUM=801.41)!(FILENUM=811.5) S ACTION=$S(EXISTS:"M",1:"I")
+ E  S ACTION=$S(EXISTS:"O",1:"I")
  S START=$P(TEMP,U,2)
  S END=$P(TEMP,U,3)
+ S TEMP=^PXD(811.8,PXRMRIEN,100,START,0)
  I FILENUM=0 D
  . D RTNLD^PXRMEXIC(PXRMRIEN,START,END,.ATTR,.RTN)
+ . I EXISTS D
+ .. D CHECKSUM^PXRMEXCS(.ATTR,START,END)
+ .. S CSUM=$$RTNCS^PXRMEXCS(ATTR("NAME"))
+ .. I ATTR("CHECKSUM")=CSUM S SAME=1,ACTION="S"
+ .;Save what was done for the installation summary.
  . S ^TMP("PXRMEXIA",$J,IND,"ROUTINE",ATTR("NAME"),ACTION)=""
  E  D
- . S TEMP=^PXD(811.8,PXRMRIEN,100,START,0)
  . S PT01=$P(TEMP,"~",2)
+ .;Save reminder name for dialog install.
+ . I FILENUM=811.9 S REMNAME=PT01
+ . D SETATTR^PXRMEXFI(.ATTR,FILENUM,PT01)
+ . I EXISTS D
+ .. D CHECKSUM^PXRMEXCS(.ATTR,START,END)
+ .. S CSUM=$$FILE^PXRMEXCS(ATTR("FILE NUMBER"),EXISTS)
+ .. I ATTR("CHECKSUM")=CSUM S SAME=1,ACTION="S"
+ . S (ATTR("NAME"),ATTR("PT01"))=PT01
+ . D SETATTR^PXRMEXFI(.ATTR,FILENUM)
  .;Save what was done for the installation summary.
+ . S ^TMP(HISTSUB,$J,IND,ATTR("FILE NAME"),PT01,ACTION)=""
+ ;If the packed component and the installed component are the same
+ ;there is nothing to do.
+ I SAME Q
+ . S ^TMP("PXRMEXIA",$J,IND,ATTR("FILE NAME"),PT01,ACTION)=""
  ;Install this component.
  I FILENUM=0 D RTNSAVE^PXRMEXIC(.RTN,ATTR("NAME"))
  E  D FILE^PXRMEXIC(PXRMRIEN,EXISTS,IND120,JND120,ACTION,.ATTR,.PXRMNMCH)
+ ;Save reminder name
+ I FILENUM=811.9 S REMNAME=PT01
+ ;If this component was not installed add to the no install message.
+ Q
+ ;
  ;===================================================
+INSDLG(PXRMRIEN,ACTION) ;Install dialog components directly
+ ;from the "SEL" array.
+ N IND,FILENUM,ITEMP,NAME,REMNAME,TEMP
+ ;Build the selection array in ^TMP("PXRMEXLD",$J,"SEL"). For dialogs
+ ;the selection array is:
+ ;file no.^FDA start^FDA end^EXISTS^IND120^JND120^NAME
+ D BLDDISP^PXRMEXD1(0)
+ ;Work through the selection array installing the dialog parts
+ ;in reverse order.
+ S IND=""
+ F  S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:(IND="")!(PXRMDONE)  D
+ . S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND)
+ . S FILENUM=$P(TEMP,U,1),NAME=$P(TEMP,U,7)
+ .;Dialog elements may be used more than once in a dialog so make sure
+ .;the element has not already been installed.
+ . S ITEMP=$P(TEMP,U,1)_U_$P(TEMP,U,5,6)_U_$$EXISTS^PXRMEXIU(FILENUM,NAME)
+ . D INSCOM(PXRMRIEN,ACTION,IND,ITEMP,.REMNAME,"PXRMEXIAD")
+INSDLG(PXRMRIEN) ;Install dialog components (in reverse order)
+ ;
+ K ^TMP("PXRMEXSI",$J)
+ N IND,TEMP,JND120,KIDSDONE
+ ;Build list of components
+ D BUILD
+ S IND="",KIDSDONE=0
+ F  S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:'IND!(KIDSDONE=1)  D
+ . S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND),JND120=$P(TEMP,U,3)
+ .;Skip install if dialog occurs more than once
+ . I $D(^TMP("PXRMEXSI",$J,JND120)) Q
+ . S ^TMP("PXRMEXSI",$J,JND120)=""
+ .;Silent Dialog Install
+ . D INSCOM(PXRMRIEN,IND,TEMP,.REMNAME)
+ K ^TMP("PXRMEXSI",$J)
+ Q
+ ;
  ;===================================================
 INSTALL(PXRMRIEN,ACTION,NOR) ;Install all components in a repository entry.
+INSTALL(PXRMRIEN,NOR) ;Install all components in a repository entry.
  ;If NOR is true do not install routines.
+ N DNAME,FILENUM,IND,PXRMDONE,PXRMNMCH,REMNAME,TEMP
+ S PXRMDONE=0
+ N DNAME,FILENUM,IND,PXRMNMCH,REMNAME,TEMP
  S NOR=$G(NOR)
  ;Initialize ^TMP globals.
 …
  ;Build the selectable list.
  D CDISP^PXRMEXLC(PXRMRIEN)
  ;Set the install date and time and type.
+ ;Set the install date and time.
  S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
- S ^TMP("PXRMEXIA",$J,"TYPE")="SILENT"
  ;Initialize the name change storage.
  K PXRMNMCH
  S IND=0
  F  S IND=$O(^TMP("PXRMEXLC",$J,"SEL",IND)) Q:(IND="")!(PXRMDONE)  D
+ F  S IND=$O(^TMP("PXRMEXLC",$J,"SEL",IND)) Q:+IND=0  D
  . S TEMP=^TMP("PXRMEXLC",$J,"SEL",IND)
  . S FILENUM=$P(TEMP,U,1)
 …
  . I FILENUM=0,NOR Q
  . ;Install dialog components
  . I FILENUM=801.41 N PXRMDONE S PXRMDONE=0 D INSDLG(PXRMRIEN,ACTION) Q
+ . I FILENUM=801.41 N PXRMDONE S PXRMDONE=0 D INSDLG(PXRMRIEN) Q
  . ;Install component
  . E  D INSCOM(PXRMRIEN,ACTION,IND,TEMP,.REMNAME,"PXRMEXIA")
+ . E  D INSCOM(PXRMRIEN,IND,TEMP,.REMNAME)
+ ;
  ;Get the dialog name

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXU1.m

-              r628
+              r636
 PXRMEXU1 ; SLC/PKR/PJH - Reminder exchange repository utilities, #1.;08/16/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXU1 ; SLC/PKR/PJH - Reminder exchange repository utilities, #1. ;09/20/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;=====================================================
 CLIST(IEN) ;Build the list of components for the repository
 …
+ ;
  ;=====================================================
 DELHIST(RIEN,IHIEN) ;Delete install history IHIEN in repository entry RIEN.
  N DA,DIK
  S DA=IHIEN,DA(1)=RIEN
  S DIK="^PXD(811.8,"_DA(1)_",130,"
  D ^DIK
+DELHIST(RIEN,IHIND) ;Delete install history IHIND in repository entry RIEN.
+ N DATE
+ S DATE=$P(^PXD(811.8,RIEN,130,IHIND,0),U)
+ K ^PXD(811.8,RIEN,130,IHIND)
+ K ^PXD(811.8,RIEN,130,"B",DATE)
+ Q
+ ;
 …
 RIEN(LIEN) ;Given the list ien return the repository ien.
  N RIEN
  S RIEN=$G(^TMP("PXRMEXLR",$J,"SEL",LIEN))
+ S RIEN=$G(^TMP("PXRMEXLR",$J,"IDX",LIEN,LIEN))
  Q RIEN
+ ;
  ;=====================================================
 SAVHIST ;Save the installation history in the repository.
+ N ACTION,DATE,CMPNT,FTYPE,IND,INDEX,ITEM,JND,NEWNAME
+ N SUB,TEMP,TOTAL,TYPE,USER
+ N ACTION,DATE,CMPNT,FTYPE,IND,INDEX,ITEM,JND,NEWNAME,TEMP,USER
  ;Find the first open spot in the Installation History node.
  S (IND,JND)=0
+ F  S IND=+$O(^PXD(811.8,PXRMRIEN,130,IND)) S JND=JND+1 Q:(IND=0)!(IND>JND)
+ F  S IND=+$O(^PXD(811.8,PXRMRIEN,130,IND)) S JND=JND+1 Q:(IND=0)!(JND>IND)
+ ;Set the 0 node.
+ S ^PXD(811.8,PXRMRIEN,130,0)=U_"811.803DA"_U_JND_U_JND
  S IND=JND
+ S JND=0
+ F SUB="PXRMEXIA","PXRMEXIAD" D
+ . S INDEX=0
+ . F  S INDEX=$O(^TMP(SUB,$J,INDEX)) Q:+INDEX=0  D
+ .. S JND=JND+1
+ .. S CMPNT=$O(^TMP(SUB,$J,INDEX,""))
+ .. S ITEM=$O(^TMP(SUB,$J,INDEX,CMPNT,""))
+ .. S ACTION=$O(^TMP(SUB,$J,INDEX,CMPNT,ITEM,""))
+ .. S NEWNAME=$G(^TMP(SUB,$J,INDEX,CMPNT,ITEM,ACTION))
+ .. S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,0)=INDEX_U_CMPNT_U_ITEM_U_ACTION_U_NEWNAME
+ ..;Set the 0 node.
+ .. S ^PXD(811.8,PXRMRIEN,130,IND,1,0)=U_"811.8031A"_U_JND_U_JND
+ ..;Check for finding item changes and save them.
+ .. S FTYPE=""
+ .. I CMPNT["DEFINITION" S FTYPE="DEFF"
+ .. I CMPNT["DIALOG" S FTYPE="DIAF"
+ .. I CMPNT["TERM" S FTYPE="TRMF"
+ .. I (FTYPE'=""),($D(^TMP(SUB,$J,FTYPE))) D
+ ... N FI,FINDING,KND,OFINDING
+ ... S KND=2
+ ... S FI=""
+ ... F  S FI=$O(^TMP(SUB,$J,FTYPE,FI)) Q:FI=""  D
+ .... S OFINDING=$O(^TMP(SUB,$J,FTYPE,FI,""))
+ .... S FINDING=^TMP(SUB,$J,FTYPE,FI,OFINDING)
+ .... I OFINDING=FINDING Q
+ S DATE=^TMP("PXRMEXIA",$J,"DT")
+ S USER=$$GET1^DIQ(200,DUZ,.01,"")
+ S ^PXD(811.8,PXRMRIEN,130,IND,0)=DATE_U_USER
+ S ^PXD(811.8,PXRMRIEN,130,"B",DATE,IND)=""
+ S (INDEX,JND)=0
+ F  S INDEX=$O(^TMP("PXRMEXIA",$J,INDEX)) Q:+INDEX=0  D
+ . S JND=JND+1
+ . S CMPNT=$O(^TMP("PXRMEXIA",$J,INDEX,""))
+ . S ITEM=$O(^TMP("PXRMEXIA",$J,INDEX,CMPNT,""))
+ . S ACTION=$O(^TMP("PXRMEXIA",$J,INDEX,CMPNT,ITEM,""))
+ . S NEWNAME=$G(^TMP("PXRMEXIA",$J,INDEX,CMPNT,ITEM,ACTION))
+ . S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,0)=INDEX_U_CMPNT_U_ITEM_U_ACTION_U_NEWNAME
+ .;Set the 0 node.
+ . S ^PXD(811.8,PXRMRIEN,130,IND,1,0)=U_"811.8031A"_U_JND_U_JND
+ .;Check for finding item changes and save them.
+ . S FTYPE=""
+ . I CMPNT["DEFINITION" S FTYPE="DEFF"
+ . I CMPNT["DIALOG" S FTYPE="DIAF"
+ . I CMPNT["TERM" S FTYPE="TRMF"
+ . I (FTYPE'=""),($D(^TMP("PXRMEXIA",$J,FTYPE))) D
+ .. N FI,FINDING,KND,OFINDING
+ .. S KND=2
+ .. S FI=""
+ .. F  S FI=$O(^TMP("PXRMEXIA",$J,FTYPE,FI)) Q:FI=""  D
+ ... S OFINDING=$O(^TMP("PXRMEXIA",$J,FTYPE,FI,""))
+ ... S FINDING=^TMP("PXRMEXIA",$J,FTYPE,FI,OFINDING)
+ ... I OFINDING=FINDING Q
+ ... S KND=KND+1
+ ... S TEMP=$E(OFINDING,1,33)
+ ... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)="    "_TEMP_$$INSCHR^PXRMEXLC((35-$L(TEMP))," ")_FINDING
+ .. S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,0)=U_"811.80315A"_U_KND_U_KND
+ .. I KND>2 D
+ ... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)="   Finding Changes"
+ ... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,2,0)="     Original"_$$INSCHR^PXRMEXLC(27," ")_"New"
+ .;
+ .;Check for TIU template replacements and save them.
+ . I CMPNT["DIALOG" S FTYPE="DIATIU"
+ . E  S FTYPE=""
+ . I (FTYPE'=""),($D(^TMP("PXRMEXIA",$J,FTYPE))) D
+ .. N KND,OTIUT,TIUT,TYPE
+ .. S TYPE=""
+ .. S KND=2
+ .. F  S TYPE=$O(^TMP("PXRMEXIA",$J,FTYPE,TYPE)) Q:TYPE=""  D
+ ... S OTIUT=""
+ ... F  S OTIUT=$O(^TMP("PXRMEXIA",$J,FTYPE,TYPE,OTIUT)) Q:OTIUT=""  D
+ .... S TIUT=$G(^TMP("PXRMEXIA",$J,FTYPE,TYPE,OTIUT))
+ .... I OTIUT=TIUT Q
+ .... I '$D(^TMP("PXRMEXIA",$J,FTYPE,TYPE,OTIUT,ITEM)) Q
  .... S KND=KND+1
  .... S TEMP=$E(OFINDING,1,33)
  .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)="    "_TEMP_$$INSCHR^PXRMEXLC((35-$L(TEMP))," ")_FINDING
+ .... S TEMP=$E(OTIUT,1,33)
+ .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)="    "_TEMP_$$INSCHR^PXRMEXLC((35-$L(TEMP))," ")_TIUT
  ... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,0)=U_"811.80315A"_U_KND_U_KND
  ... I KND>2 D
  .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)="   Finding Changes"
+ .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)="   "_TYPE
  .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,2,0)="     Original"_$$INSCHR^PXRMEXLC(27," ")_"New"
- ..;
- ..;Check for TIU template replacements and save them.
- .. I CMPNT["DIALOG" S FTYPE="DIATIU"
- .. E  S FTYPE=""
- .. I (FTYPE'=""),($D(^TMP(SUB,$J,FTYPE))) D
- ... N KND,OTIUT,TIUT,TYPE
- ... S TYPE=""
- ... S KND=2
- ... F  S TYPE=$O(^TMP(SUB,$J,FTYPE,TYPE)) Q:TYPE=""  D
- .... S OTIUT=""
- .... F  S OTIUT=$O(^TMP(SUB,$J,FTYPE,TYPE,OTIUT)) Q:OTIUT=""  D
- ..... S TIUT=$G(^TMP(SUB,$J,FTYPE,TYPE,OTIUT))
- ..... I OTIUT=TIUT Q
- ..... I '$D(^TMP(SUB,$J,FTYPE,TYPE,OTIUT,ITEM)) Q
- ..... S KND=KND+1
- ..... S TEMP=$E(OTIUT,1,33)
- ..... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)="    "_TEMP_$$INSCHR^PXRMEXLC((35-$L(TEMP))," ")_TIUT
- .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,0)=U_"811.80315A"_U_KND_U_KND
- .... I KND>2 D
- ..... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)="   "_TYPE
- ..... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,2,0)="     Original"_$$INSCHR^PXRMEXLC(27," ")_"New"
- ;If JND is still 0 then there was nothing to save.
- I JND>0 D
- .;Save the header information.
- . S DATE=^TMP("PXRMEXIA",$J,"DT")
- . S TYPE=^TMP("PXRMEXIA",$J,"TYPE")
- . S USER=$$GET1^DIQ(200,DUZ,.01,"")
- . S ^PXD(811.8,PXRMRIEN,130,IND,0)=DATE_U_USER_U_TYPE
- . S ^PXD(811.8,PXRMRIEN,130,"B",DATE,IND)=""
- .;Set the 0 node.
- . S (KND,TOTAL)=0
- . F  S KND=+$O(^PXD(811.8,PXRMRIEN,130,KND)) Q:KND=0  S TOTAL=TOTAL+1
- . S ^PXD(811.8,PXRMRIEN,130,0)=U_"811.803DA"_U_IND_U_TOTAL
  K ^TMP("PXRMEXIA",$J)
+ K ^TMP("PXRMEXIAD",$J)
+ Q
+ ;
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXU2.m

-              r628
+              r636
 PXRMEXU2 ; SLC/PKR/PJH - Reminder exchange repository utilities, #2. ;11/21/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXU2 ; SLC/PKR/PJH - Reminder exchange repository utilities, #2. ;09/20/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;=====================================================
 FDA(IND,LC,TMPIND,FILENAME) ;Build the XML FDA output.
 …
  S ^TMP("PXRMEXRS",$J,1,0)="<?xml version=""1.0"" standalone=""yes""?>"
  S ^TMP("PXRMEXRS",$J,2,0)="<REMINDER_EXCHANGE_FILE_ENTRY>"
  S VERSN=$P(^PXRM(800,1,"VERSION"),U,1)
+ S VERSN=^PXRM(800,1,"VERSION")
  S ^TMP("PXRMEXRS",$J,3,0)="<PACKAGE_VERSION>"_VERSN_"</PACKAGE_VERSION>"
  ;The pointer to the index will be on line 4 so leave room.
 …
  . S ^TMP($J,"CIND",NCMPNT,"M_ROUTINE_START")=LC
  . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<ROUTINE_NAME>"_RNAME_"</ROUTINE_NAME>"
- . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<CHECKSUM>"_^TMP("PXRMEXCS",$J,"ROUTINE",RNAME)_"</CHECKSUM>"
  . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<CODE>"
  . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<![CDATA["
 …
  ... S ^TMP("PXRMEXRS",$J,LC,0)="<POINT_01>"_$$TOXML^PXRMEXU3(PT01)_"</POINT_01>"
  ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<INTERNAL_ENTRY_NUMBER>"_+SIENS_"</INTERNAL_ENTRY_NUMBER>"
- ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<CHECKSUM>"_^TMP("PXRMEXCS",$J,IND,FILENAME)_"</CHECKSUM>"
  ... S ^TMP($J,"CIND",NCMPNT,"FDA_START")=LC+3
  ... D FDA(IND,.LC,TMPIND,FILENAME)
 …
  . S DESL("SOURCE")=^TMP(TMPIND,$J,"SRC","USER")_" at "_^TMP(TMPIND,$J,"SRC","SITE")
  . S DESL("DATEP")=^TMP(TMPIND,$J,"SRC","DATE")
  . S DESL("VRSN")=VERSN
+ . S DESL("VRSN")=$G(^PXRM(800,1,"VERSION"))
  . S DESC="^TMP(TMPIND,$J,""DESC"")"
  . S KEYWORD="^TMP(TMPIND,$J,""KEYWORD"")"
  . D DESC^PXRMEXU1(IENROOT(1),.DESL,$NA(@DESC),$NA(@KEYWORD))
+ K ^TMP($J,"CIND"),^TMP("PXRMEXRS",$J)
+ K ^TMP(TMPIND,$J),^TMP("PXRMEXCS",$J)
+ K ^TMP($J,"CIND")
+ K ^TMP("PXRMEXRS",$J)
+ K ^TMP(TMPIND,$J)
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXU4.m

-              r628
+              r636
 PXRMEXU4 ; SLC/PJH,PKR - Reminder Exchange #4, dialog changes. ;05/16/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXU4 ; SLC/PJH,PKR - Reminder Exchange #4, dialog changes. ;01/19/2005
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;===============================================
 DLG(FDA,NAMECHG) ;Check the dialog for renamed entries, called by
 …
  D BLDALIST^PXRMVPTR(801.4118,.01,.ALIST)
  ;Plus field 15 files
+ ;S ALIST("MH")=601,ALIST("TX")=811.2
+ S ALIST("MH")=601.71,ALIST("TX")=811.2
+ S ALIST("MH")=601,ALIST("TX")=811.2
  S ALIST("WH")=790.404
  ;Plus field 17 file
 …
  .. I Y="" S ACTION="Q" Q
  .. I Y'="" S FDA(801.412,IENS,2)=$P(Y,U,2)
- ;Process Result Groups
- F  S IENS=$O(FDA(801.41121,IENS)) Q:IENS=""  D  I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
- . S PT01=$G(FDA(801.41121,IENS,.01)) Q:PT01=""
- . S FILENUM=801.41,NEWNAM=$G(NAMECHG(FILENUM,PT01))
- .I NEWNAM'="" D
- .. S FDA(801.41121,IENS,2)=NEWNAM,PT01=NEWNAM
- .S IEN=$$EXISTS^PXRMEXIU(FILENUM,PT01)
- .I IEN=0 D
- ..;Get replacement
- .. N DIC,DIR,DUOUT,MSG,X,Y
- .. S MSG(1)=" "
- .. S MSG(2)="RESULT GROUP entry "_PT01_" does not exist."
- .. D MES^XPDUTL(.MSG)
- .. S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
- .. I ACTION="S" S ACTION="Q"
- .. I ACTION="Q" Q
- .. I ACTION="D" K FDA(801.41121,IENS) Q
- .. S DIC=FILENUM
- .. S DIC(0)="AEMNQ"
- .. S DIC("S")="I ""S""[$P(^PXRMD(801.41,Y,0),U,4)"
- .. S Y=-1
- .. F  Q:+Y'=-1  D
- ...;If this is being called during a KIDS install we need echoing on.
- ... I $D(XPDNM) X ^%ZOSF("EON")
- ... D ^DIC
- ... I $D(XPDNM) X ^%ZOSF("EOFF")
- ... I $D(DUOUT) S Y="" Q
- ... I Y=-1 D BMES^XPDUTL("You must input a replacement!")
- .. I Y="" S ACTION="Q" Q
- .. I Y'="" S FDA(801.41121,IENS,.01)=$P(Y,U,2)
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMFF.m

-              r628
+              r636
 PXRMFF ;SLC/PKR - Clinical Reminders function finding evaluation. ;3/29/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMFF ;SLC/PKR - Clinical Reminders function finding evaluation. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;===========================================
 EVAL(DFN,DEFARR,FIEVAL) ;Evaluate function findings.
 …
  . S LNAME(IND)="PXRMFF"_IND
  . K ^TMP($J,LNAME(IND))
  . D EVALPL^PXRMTERL(.FINDPA,.TERMARR,LNAME(IND))
+ . D EVALPL^PXRMTERM(.FINDPA,.TERMARR,LNAME(IND))
  .;Get rid of the false part of the list.
  . K ^TMP($J,LNAME(IND),0)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMFF0.m

-              r628
+              r636
 PXRMFF0 ;SLC/PKR - Clinical Reminders function finding routines. ;09/11/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMFF0 ;SLC/PKR - Clinical Reminders function finding routines. ;06/23/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;============================================
 …
+ ;
  ;============================================
-NUMERIC(LIST,FIEVAL,VALUE) ;Given a finding, return the first numeric
- ;portion of one of the "CSUB" values. Based on original work
- ;by R. Silverman.
- S VALUE=$G(FIEVAL(LIST(1),LIST(2),LIST(3)))
- S VALUE=$$FIRSTNUM(VALUE)
+ Q
+ ;
-FIRSTNUM(STRING) ;return the first numeric portion of a string.
- N CHAR,DONE,IND,NUMBER,NUMERIC
- S NUMERIC="+-.1234567890"
- S STRING=$TR(STRING," ")
- S DONE=0,IND=0,NUMBER=""
- F  Q:DONE  D
- . S IND=IND+1,CHAR=$E(STRING,IND)
- . I CHAR="" S DONE=1 Q
- . I NUMERIC[CHAR S NUMBER=NUMBER_CHAR
- . I NUMBER'="",NUMERIC'[CHAR S DONE=1
- Q +NUMBER
+ ;
- ;============================================
 VALUE(LIST,FIEVAL,VALUE) ;Given a finding return one of its "CSUB"
  ;values.

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMFFAT.m

-              r628
+              r636
 PXRMFFAT ;SLC/PKR - Function Finding argument type routines. ;09/11/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMFFAT ;SLC/PKR - Function Finding argument type routines. ;08/03/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;============================================
 …
+ ;
  ;============================================
-NUMERIC(AN) ;
- Q $S(AN=1:"F",AN=2:"N",AN=3:"S",1:"U")
+ ;
- ;============================================
 VALUE(AN) ;
  Q $S(AN=1:"F",AN=2:"N",AN=3:"S",1:"U")

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMFFDB.m

-              r628
+              r636
 PXRMFFDB ;SLC/PKR - Function finding data structure builder. ;10/31/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMFFDB ;SLC/PKR - Function finding data structure builder. ;06/22/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;===========================================
 …
  N PFSTACK,REPL,RS,TEMP,TS,XS
  S IENB=DA_","_DA(1)_","
  S OPER="!&-+<>='"
+ S OPER="!&<>='"
  S XS=$$PSPACE(X)
  D POSTFIX^PXRMSTAC(XS,OPER,.PFSTACK)
 …
 PSPACE(OPR) ;OPR is an operand in a function finding, if some portion
  ;of OPR is a string translate a space into "~" so it is preserved.
+ ;Note this will work for the entire function string.
+ N DONE,END,START,TNS,TS
+ S DONE=0,END=1
+ F  Q:DONE  D
+ . S START=$F(OPR,"""",END)
+ . I START=0 S DONE=1 Q
+ . S END=$F(OPR,"""",START)
+ . S TS=$E(OPR,START,END-2)
+ . S TNS=$TR(TS," ","~")
+ . S OPR=$$STRREP^PXRMUTIL(OPR,TS,TNS)
+ N END,START,TNS,TS
+ S START=$F(OPR,"""")
+ I START=0 Q OPR
+ S END=$F(OPR,"""",START)-2
+ S TS=$E(OPR,START,END)
+ S TNS=$TR(TS," ","~")
+ S OPR=$$STRREP^PXRMUTIL(OPR,TS,TNS)
  Q OPR
+ ;
 …
  N DAI,DATE,FUNIEN,IND,LIST,MFUN,OPER,PFSTACK,TEMP,TEXT,VALID
  S DAI=DA(1)
  S OPER="!&-+<>='"
+ S OPER="!&<>='"
  ;Define the allowed M functions.
  S MFUN("$P")=""

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMGECN.m

-              r628
+              r636
 PXRMGECN ;SLC/JVS GEC-Score Reports-cont'd ;06/01/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMGECN ;SLC/JVS GEC-Score Reports-cont'd ;6/19/03  20:58
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ Q
 SUM ;By Summary by Patient
  N CAT,HF,DATE,DFN,Y,HFN,CNTREF,X,REFNUM,SUM,GSUM,CATDANA
  N DATER,SDATE,SCNT
+ N DATER,SDATE
  D E^PXRMGECV("HS1",1,BDT,EDT,"F",DFNONLY)
  I FORMAT="D" S FOR=0

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMHF.m

-              r628
+              r636
 PXRMHF ; SLC/PKR - Handle Health Factor findings. ;06/01/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMHF ; SLC/PKR - Handle Health Factor findings. ;12/23/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;=====================================================
 …
  N EM,FIEN,IND,JND,LVL,NOUT,PNAME,TEMP,TEXTOUT,VDATE
  S FIEN=$P(IFIEVAL("FINDING"),";",1)
- ;DBIA #3083
  S PNAME=$P(^AUTTHF(FIEN,0),U,1)
  S NLINES=NLINES+1

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMINDC.m

-              r628
+              r636
 PXRMINDC ; SLC/PKR - Index counting routines. ;03/06/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMINDC ; SLC/PKR - Index counting routines. ;04/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;========================================================
 CNT5(FILENUM,COUNT) ;Get date counts for indexes where the date
  ;is at subscript 5. Works for file numbers:
  ;63, 70, 120.5, 601.2, 601.84,
+ ;63, 70, 120.5, 601.2,
  ;9000010.11, 9000010.12, 9000010.13, 9000010.16, 9000010.23
  N DAS,DATE,DFN,IND,ITEM,YEAR
 …
  S ROUTINE(120.5)="CNT5^PXRMINDC"
  S ROUTINE(601.2)="CNT5^PXRMINDC"
- S ROUTINE(601.84)="CNT5^PXRMINDC"
  S ROUTINE(9000011)="CNTPL^PXRMINDC"
  S ROUTINE(9000010.07)="CNT6^PXRMINDC"

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMINDD.m

-              r628
+              r636
 PXRMINDD ; SLC/PKR - Index string date checking routines. ;03/06/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMINDD ; SLC/PKR - Index string date checking routines. ;05/02/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;========================================================
 CNT5(FILENUM,NSD) ;Check for string dates for indexes where the date
  ;is at subscript 5. Works for file numbers:
  ;63, 70, 120.5, 601.2, 601.84
+ ;63, 70, 120.5, 601.2,
  ;9000010.11, 9000010.12, 9000010.13, 9000010.16, 9000010.23
  N DAS,DATE,DFN,IND,ITEM
 …
  S ROUTINE(120.5)="CNT5^PXRMINDD"
  S ROUTINE(601.2)="CNT5^PXRMINDD"
- S ROUTINE(601.84)="CNT5^PXRMINDD"
  S ROUTINE(9000011)="CNTPL^PXRMINDD"
  S ROUTINE(9000010.07)="CNT6^PXRMINDD"

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMINDL.m

-              r628
+              r636
 PXRMINDL ; SLC/PKR - List building routines. ;07/26/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMINDL ; SLC/PKR - List building routines. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;================================================
 EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;General patient list term evaluator.
 …
  N DAS,DATE,DFN,DS,NFOUND
  K ^TMP($J,PLIST)
  I FILENUM=601.84 D SEVALPL^PXRMMH(ITEM,NOCC,BDT,EDT,PLIST) Q
+ I FILENUM=601.2 D SEVALPL^PXRMMH(ITEM,NOCC,BDT,EDT,PLIST) Q
  S DS=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
  S DFN=0
 …
  D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
  S INVFD=$P(PFINDPA(0),U,16)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
  D GETSTATI^PXRMSTAT(FILENUM,.PFINDPA,.STATUSA)
  D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+ ;Ignore any negative occurrence counts, date reversal not allowed
+ ;in patient lists.
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
+ S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
+ S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC)
  I SSFIND D FPLISTSS(FILENUM,SNODE,ITEM,NGET,BDT,EDT,USESTRT,TGLIST)
  I 'SSFIND D FPLIST(FILENUM,SNODE,ITEM,NGET,BDT,EDT,TGLIST)
 …
  .. I PFINDPA(0)["LAB(60" S DAS=ITEM_"~"_DAS
  ..;If this is a Mental Health finding attach the scale to DAS.
  .. I PFINDPA(0)["YTT(601.71" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)
+ .. I PFINDPA(0)["YTT(601" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)
  .. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
  .. S VALUE=$G(FIEVD("VALUE"))

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMINDX.m

-              r628
+              r636
 PXRMINDX ; SLC/PKR - Routines for utilizing the index. ;10/11/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMINDX ; SLC/PKR - Routines for utilizing the index. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;Code for patient findings.
  ;================================================================
 …
  S SDIR=$S(NOCC<0:+1,1:-1)
  S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
  S NGET=$S(UCIFS:50,1:NOCC)
+ S NGET=$S(UCIFS:"*",1:NOCC)
  ;Determine if this is a finding with a start and stop date.
  S SSFIND=$S(FILENUM=52:1,FILENUM["55":1,FILENUM=100:1,1:0)
 …
  . I PFINDPA(0)["LAB(60" S DAS=ITEM_"~"_DAS
  .;If this is a Mental Health finding attach the scale to DAS.
  . I PFINDPA(0)["YTT(601.71" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)
+ . I PFINDPA(0)["YTT(601" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)
  . D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
  . I INVFD D GETDATA^PXRMVSIT(FIEVD("VISIT"),.FIEVD,0)
 …
  ;data for regular files. FLIST is returned in date order, i.e.,
  ;FLIST(1) is the most recent SDIR=-1, oldest SDIR=+1.
  I FILENUM=601.84 D SEVALFI^PXRMMH(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST) Q
+ I FILENUM=601.2 D SEVALFI^PXRMMH(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST) Q
  N DAS,DATE,DONE,EDTT
  S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMISE.m

-              r628
+              r636
 PXRMISE ; SLC/PKR - Index size estimating routines. ;03/13/2006
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMISE ; SLC/PKR - Index size estimating routines. ;01/12/2005
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;========================================================
 …
  W !,"Queue the Clinical Reminders index size estimation."
  S DIR("A",1)="Enter the date and time you want the job to start."
+ S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
+ S DIR("A")="Start the task at: "
+ S DIR("A")="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")_" "
  S DIR(0)="DAU"_U_MINDT_"::RSX"
  D ^DIR

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLCD.m

-              r628
+              r636
 PXRMLCD ; SLC/PKR - Reminder Patient List Patients ;11/02/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLCD ; SLC/PKR - Reminder Patient List Patients ;06/30/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;Display list creation documentation.
 …
  S IND="",PXRMDONE=0
  F  S IND=$O(VALMY(IND)) Q:(IND="")!(PXRMDONE)  D
  . S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
+ . S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND)
  . D EN^PXRMLCD(LISTIEN)
  S VALMBCK="R"
 …
  ;===========================================================
 HDR ; Header code
+ S VALMHDR(1)="Documentation for creation of patient list:"
+ S VALMHDR(2)=" "_$P(^PXRMXP(810.5,LISTIEN,0),U,1)
+ S VALMHDR(1)="Documentation for creation of patient list "_$P(^PXRMXP(810.5,LISTIEN,0),U,1)
  S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLCR.m

-              r628
+              r636
 PXRMLCR ; SLC/PJH - Create Patient List from individual finding rule; 10/18/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLCR ; SLC/PJH - Create Patient List from individual finding rule; 08/03/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ; Called from PXRM PATIENT LIST CREATE protocol
 …
 TPAT S PXRMTPAT=$$ASKYN^PXRMEUT("N","Include test patients on the list")
  Q:$D(DTOUT)  G:$D(DUOUT) DPAT
- I $G(PXRMDEBG) D RUN^PXRMLCR(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT) Q
  ;Build patient list in background
  N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
 …
+ ;
  I CALL=4 D
  .S HTEXT(1)="Enter Y to turn on debug output."
  .S HTEXT(2)="The debug output will send a series of MailMan messages to the requestor of the report"
  .S HTEXT(3)="-**WARNING**- the reminder report will take longer to run if you turn on this option!"
+ .S HTEXT(1)="Enter Y to turn on Debug output."
+ .S HTEXT(2)="The debug output will send a series of mailman message to the requestor of the report"
+ .S HTEXT(3)="**WARNING** the reminder report will take longer to run if you turn on this option!"
  D HELP^PXRMEUT(.HTEXT)
+ Q
 …
  S DIC("A")=TEXT
  S DIC("S")="I $P($G(^(100)),U)'=""N"""
+ ;If this is a new entry save the creator, make the TYPE public and
+ ;CLASS local.
+ S DIC("DR")=".07///`"_DUZ_";.08///PUB;100///L"
+ S DIC("DR")="100///L"
  W !
  D ^DIC
 …
 RUN(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT) ;
  ;Process rule set and update final patient list
  D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,"","","",PXRMDPAT,PXRMTPAT,"")
+ D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,"","","",PXRMDPAT,PXRMTPAT)
  ;Clear ^TMP lists created for rule
  D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLIST.m

-              r628
+              r636
 PXRMLIST ; SLC/PKR/PJH - Clinical Reminders list functions. ;07/17/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMLIST ; SLC/PKR/PJH - Clinical Reminders list functions. ;10/04/2000
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;Used in the reminder exchange utility for building lists of
  ;reminders, Exchange File entries, etc.
 …
+ ;
  ;=======================================================
+FMT(NUMBER,NAME,SOURCE,DATE,FMTSTR,NL,OUTPUT) ;Format  entry number, name,
+ ;source, and date packed for LM display.
+ N TEMP,TSOURCE
+ S TEMP=NUMBER_U_NAME
+FRE(NUMBER,NAME,SOURCE,DATE) ;Format  entry number, name, source,
+ ;and date packed.
+ N TEMP,TNAME,TSOURCE
+ S TEMP=$$RJ^XLFSTR(NUMBER,4," ")
+ S TNAME=$E(NAME,1,27)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,29," ")
  S TSOURCE=$E($P(SOURCE,",",1),1,12)_"@"_$E($P(SOURCE," at ",2),1,12)
  S TEMP=TEMP_U_TSOURCE
+ S TEMP=TEMP_$$LJ^XLFSTR(TSOURCE,23," ")
  S DATE=$$FMTE^XLFDT(DATE,"5Z")
+ S TEMP=TEMP_U_DATE
+ D COLFMT^PXRMTEXT(FMTSTR,TEMP," ",.NL,.OUTPUT)
+ Q
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(DATE,30," ")
+ Q TEMP
+ ;
  ;=======================================================
 …
+ ;
  ;=======================================================
 REXL(RLIST) ;Build a list of exchange repository entries.
  N DATE,EXIEN,FMTSTR,IND,NAME,NL,NUM,OUTPUT,SOURCE,STR
+RE(RLIST,IEN) ;Build a list of repository entries.
+ N DATE,IND,NAME,SOURCE
  ;Build the list in alphabetical order.
+ S FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLL")
+ S (NUM,VALMCNT)=0
+ S VALMCNT=0
  S NAME=""
  F  S NAME=$O(^PXD(811.8,"B",NAME)) Q:NAME=""  D
  . S DATE=""
  . F  S DATE=$O(^PXD(811.8,"B",NAME,DATE)) Q:DATE=""  D
+ .. S EXIEN=$O(^PXD(811.8,"B",NAME,DATE,""))
+ .. S SOURCE=$P(^PXD(811.8,EXIEN,0),U,2)
+ .. S NUM=NUM+1
+ .. S ^TMP(RLIST,$J,"SEL",NUM)=EXIEN
+ .. D FMT(NUM,NAME,SOURCE,DATE,FMTSTR,.NL,.OUTPUT)
+ .. F IND=1:1:NL D
+ ... S VALMCNT=VALMCNT+1,^TMP(RLIST,$J,VALMCNT,0)=OUTPUT(IND)
+ ... S ^TMP(RLIST,$J,"IDX",VALMCNT,NUM)=""
+ S ^TMP(RLIST,$J,"VALMCNT")=VALMCNT
+ .. S IND=$O(^PXD(811.8,"B",NAME,DATE,""))
+ .. S SOURCE=$P(^PXD(811.8,IND,0),U,2)
+ .. S VALMCNT=VALMCNT+1
+ .. S RLIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,SOURCE,DATE)
+ .. S IEN(VALMCNT)=IND
+ S RLIST("VALMCNT")=VALMCNT
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLLED.m

-              r628
+              r636
 PXRMLLED ; SLC/PJH - Edit a location list. ;06/25/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLLED ; SLC/PJH - Edit a location list. ;12/23/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;================================================================
 …
  S DR(2,810.9001)=".01;1"
  D ^DIE
  I $D(Y) G RD
+ I $D(Y) G DES
+ ;
  ;Hospital Locations

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLOCF.m

-              r628
+              r636
 PXRMLOCF ; SLC/PKR - Handle location findings. ;10/11/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLOCF ; SLC/PKR - Handle location findings. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;This routine is for location list patient findings.
  ;=================================================
 ALL(FILENUM,DFN,PFINDPA,FIEVAL) ;Get all Visits with a location
  ;for a patient.
  N BDT,BTIME,CASESEN,COND,CONVAL,DAS,DATE,DEND,DONE,DS,EDT,FIEVD
  N ICOND,INVBD,INVDATE,INVDT,INVED,NFOUND,NOCC
  N SAVE,SDIR,TEMP,TIME,UCIFS
+ N BDT,CASESEN,COND,CONVAL,DAS,DATE,DONE,EDT,ENTYPE,FIEVD,HLOC
+ N ICOND,IND,NFOUND,NOCC
+ N SAVE,SDIR,TEMP,UCIFS,VDATE
  ;Set the finding search parameters.
  D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
  S SDIR=$S(NOCC<0:-1,1:1)
+ S SDIR=$S(NOCC<0:+1,1:-1)
  S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
  D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
  S (DONE,NFOUND)=0
+ S DEND=$S(EDT[".":EDT,1:EDT+.235959)
+ S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)
+ S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)
+ I SDIR=1 S DS=INVED-.000001
+ I SDIR=-1 S DS=INVBD+.000001
+ S INVDT=DS,(DONE,NFOUND)=0
+ I SDIR=1 S VDATE=BDT-.0000001
+ I SDIR=-1 S VDATE=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
  ;DBIA 2028
+ F  S INVDT=$O(^AUPNVSIT("AA",DFN,INVDT),SDIR) Q:(DONE)!(INVDT="")  D
+ . S INVDATE=$P(INVDT,".",1)
+ . I (SDIR=1),INVDATE>INVBD S DONE=1 Q
+ . I (SDIR=-1),INVDATE<INVED S DONE=1 Q
+ . S TIME="."_$P(INVDT,".",2)
+ . I INVDATE=INVED,TIME>ETIME Q
+ . I INVDATE=INVBD,TIME<BTIME Q
+ . S DAS=0
+ . F  S DAS=$O(^AUPNVSIT("AA",DFN,INVDT,DAS)) Q:(DAS="")!(DONE)  D
+ .. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
+ .. S CONVAL=$S(COND="":1,1:$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD))
+ .. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
+ .. I SAVE D
+ ... S TEMP=^AUPNVSIT(DAS,0)
+ ... S NFOUND=NFOUND+1
+ ... S FIEVAL(NFOUND)=CONVAL
+ ... I COND'="" S FIEVAL(NFOUND,"CONDITION")=CONVAL
+ ... S FIEVAL(NFOUND,"DAS")=DAS
+ ... S FIEVAL(NFOUND,"DATE")=$P(TEMP,U,1)
+ ... M FIEVAL(NFOUND)=FIEVD
+ ... I $G(PXRMDEBG) M FIEVAL(NFOUND,"CSUB")=FIEVD
+ ... I NFOUND=NOCC S DONE=1
+ F  S VDATE=+$O(^AUPNVSIT("AET",DFN,VDATE),SDIR) Q:(VDATE=0)!(DONE)  D
+ . I SDIR=1,VDATE>EDT S DONE=1 Q
+ . I SDIR=-1,VDATE<BDT S DONE=1 Q
+ . S HLOC=""
+ . F  S HLOC=$O(^AUPNVSIT("AET",DFN,VDATE,HLOC)) Q:(HLOC="")!(DONE)  D
+ .. S ENTYPE=""
+ .. F  S ENTYPE=$O(^AUPNVSIT("AET",DFN,VDATE,HLOC,ENTYPE)) Q:(ENTYPE="")!(DONE)  D
+ ... S DAS=0
+ ... F  S DAS=$O(^AUPNVSIT("AET",DFN,VDATE,HLOC,ENTYPE,DAS)) Q:(DAS="")!(DONE)  D
+ .... D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
+ .... S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
+ .... S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
+ .... I SAVE D
+ ..... S NFOUND=NFOUND+1
+ ..... S FIEVAL(NFOUND)=CONVAL
+ ..... I COND'="" S FIEVAL(NFOUND,"CONDITION")=CONVAL
+ ..... S FIEVAL(NFOUND,"DAS")=DAS
+ ..... S FIEVAL(NFOUND,"DATE")=VDATE
+ ..... M FIEVAL(NFOUND)=FIEVD
+ ..... I $G(PXRMDEBG) M FIEVAL(NFOUND,"CSUB")=FIEVD
+ ..... I NFOUND=NOCC S DONE=1
  ;Save the finding result.
  D SFRES^PXRMUTIL(-SDIR,NFOUND,.FIEVAL)
+ D SFRES^PXRMUTIL(SDIR,NFOUND,.FIEVAL)
  S FIEVAL("FILE NUMBER")=FILENUM
+ Q
 …
  ;Set the finding search parameters.
  D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
+ S SDIR=$S(NOCC<0:-1,1:1)
+ S SDIR=$S(NOCC<0:+1,1:-1)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
  D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
+ S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
+ S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC)
  ;Get a list of unique locations.
  D LOCLIST(ITEM,"HLOCL")
  D FPDAT(DFN,"HLOCL",NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)
+ D FPDAT(DFN,"HLOCL",NGET,BDT,EDT,.NFOUND,.FLIST)
  I NFOUND=0 S FIEVAL=0 Q
  S NP=0
 …
+ ;
  ;=================================================
 FPDAT(DFN,HLOCL,NOCC,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient data for
+FPDAT(DFN,HLOCL,NOCC,BDT,EDT,NFOUND,FLIST) ;Find patient data for
  ;visits at a specified hospital location. Return up to NOCC most
  ;recent entries in FLIST where FLIST(1) is the most recent.
+ ;"AA" in Visit file is inverse date_.time instead of a full inverse
+ ;date and time. For example if the date/time is 3030704.104449 then
+ ;"AA" has 6969295.104449 instead of 6969295.89555
+ N BTIME,DAS,DATE,DEND,DLIST,DONE,DS,ETIME,HLOC
+ N INVBD,INVDATE,INVDT,INVED,NF,TEMP,TIME
+ S DEND=$S(EDT[".":EDT,1:EDT+.235959)
+ S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)
+ S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)
+ I SDIR=1 S DS=INVED-.000001
+ I SDIR=-1 S DS=INVBD+.000001
+ ;DBIA #2028
+ S INVDT=DS,(DONE,NFOUND)=0
+ F  S INVDT=$O(^AUPNVSIT("AA",DFN,INVDT),SDIR) Q:(INVDT="")!(DONE)  D
+ N DAS,DATE,DLIST,ENTYPE,HLOC,NF
+ S NFOUND=0
+ S DATE=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
+ ;DBIA 2028
+ F  S DATE=+$O(^AUPNVSIT("AET",DFN,DATE),-1) Q:(DATE=0)!(DATE<BDT)!(NFOUND=NOCC)  D
+ . S HLOC=""
+ . F  S HLOC=$O(^TMP($J,HLOCL,HLOC)) Q:(HLOC="")!(NFOUND=NOCC)  D
+ .. I '$D(^AUPNVSIT("AET",DFN,DATE,HLOC)) Q
+ .. S NF=0
+ .. S ENTYPE=""
+ .. F  S ENTYPE=$O(^AUPNVSIT("AET",DFN,DATE,HLOC,ENTYPE)) Q:(ENTYPE="")!(NFOUND=NOCC)  D
+ ... S DAS=0
+ ... F  S DAS=$O(^AUPNVSIT("AET",DFN,DATE,HLOC,ENTYPE,DAS)) Q:(DAS="")!(NFOUND=NOCC)  D
+ ....;Check the associated appointment for a valid status.
+ .... I '$$VAPSTAT^PXRMVSIT(DAS) Q
+ .... S NF=NF+1,NFOUND=NFOUND+1
+ .... S DLIST(DATE,NF)=DAS
+ S NFOUND=0
+ S DATE=""
+ F  S DATE=$O(DLIST(DATE),-1) Q:DATE=""  D
  . S NF=0
+ . S INVDATE=$P(INVDT,".",1)
+ . I (SDIR=1),INVDATE>INVBD S DONE=1 Q
+ . I (SDIR=-1),INVDATE<INVED S DONE=1 Q
+ . S TIME="."_$P(INVDT,".",2)
+ . I INVDATE=INVED,TIME>ETIME Q
+ . I INVDATE=INVBD,TIME<BTIME Q
+ . S DAS=0
+ . F  S DAS=$O(^AUPNVSIT("AA",DFN,INVDT,DAS)) Q:(DAS="")!(DONE)  D
+ .. S TEMP=^AUPNVSIT(DAS,0)
+ .. S HLOC=$P(TEMP,U,22)
+ .. I HLOC="" Q
+ .. I '$D(^TMP($J,HLOCL,HLOC)) Q
+ ..;Check the associated appointment for a valid status.
+ .. I '$$VAPSTAT^PXRMVSIT(DAS) Q
+ .. S DATE=$P(TEMP,U,1)
+ .. S NF=NF+1,NFOUND=NFOUND+1
+ .. I NFOUND=NOCC S DONE=1
+ .. S DLIST(INVDT,NF)=DAS_U_DATE
+ S INVDT="",NFOUND=0
+ F  S INVDT=$O(DLIST(INVDT)) Q:INVDT=""  D
+ . S NF=0
+ . F  S NF=$O(DLIST(INVDT,NF)) Q:NF=""  D
+ . F  S NF=$O(DLIST(DATE,NF)) Q:NF=""  D
  .. S NFOUND=NFOUND+1
  .. S FLIST(NFOUND)=DLIST(INVDT,NF)
+ .. S FLIST(NFOUND)=DLIST(DATE,NF)_U_DATE
  K ^TMP($J,"HLOCL")
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLOCL.m

-              r628
+              r636
 PXRMLOCL ; SLC/PKR - Handle location findings. ;07/26/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLOCL ; SLC/PKR - Handle location findings. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;This routine is for location list patient lists.
  ;=============================================
 …
  ;a visit to a hospital location. Return the list in ^TMP($J,PLIST).
  N BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED
  N NFOUND,SC,TEMP,TGLIST,TIME
+ N NFOUND,TEMP,TGLIST,TIME
  S TGLIST="FPLIST_PXRMLOCL"
  K ^TMP($J,TGLIST)
  S DEND=$S(EDT[".":EDT,1:EDT+.235959)
+ S DEND=$S(EDT[".":EDT,1:EDT+.240001)
  ;"AHL" in Visit file is inverse date_.time instead of a full inverse
  ;date and time. For example if the date/time is 3030704.104449 then
  ;"AHL" has 6969295.104449 instead of 6969295.89555
  S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)
  S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)
  S DS=INVED-.000001
+ S INVBD=9999999-$P(BDT,".",1),BTIME=+("."_$P(BDT,".",2))
+ S INVED=9999999-$P(DEND,".",1),ETIME=+("."_$P(DEND,".",2))
+ S DS=INVED-1
  S HLOC=""
  F  S HLOC=$O(^TMP($J,HLOCL,HLOC)) Q:HLOC=""  D
 …
  .. S INVDATE=$P(INVDT,".",1)
  .. I INVDATE>INVBD S DONE=1 Q
  .. S TIME="."_$P(INVDT,".",2)
+ .. S TIME=+("."_$P(INVDT,".",2))
  .. I INVDATE=INVED,TIME>ETIME Q
  .. I INVDATE=INVBD,TIME<BTIME Q
+ .. I INVDATE=INVBD,BTIME>TIME S DONE=1 Q
  .. S DAS=0
  .. F  S DAS=$O(^AUPNVSIT("AHL",HLOC,INVDT,DAS)) Q:DAS=""  D
 …
  ... I '$$VAPSTAT^PXRMVSIT(DAS) Q
  ... S TEMP=^AUPNVSIT(DAS,0)
+ ... S DFN=$P(TEMP,U,5)
  ... S DATE=$P(TEMP,U,1)
+ ... S DFN=$P(TEMP,U,5)
+ ... S SC=$P(TEMP,U,7)
+ ... S ^TMP($J,TGLIST,DFN,INVDT,DAS)=DATE_U_HLOC_U_SC
+ ... S ^TMP($J,TGLIST,DFN,INVDT,DAS)=DATE_U_HLOC
  ;Return the NOCC most recent for each patient.
  S DFN=0
 …
+ ;
  ;=============================================
-FTEST(FILENUM,HLOCL,NOCC,BDT,EDT,PLIST) ;Find patient list data for
- ;a visit to a hospital location. Return the list in ^TMP($J,PLIST).
- N BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED
- N NFOUND,TEMP,TGLIST,TIME
- S TGLIST="FPLIST_PXRMLOCL"
- K ^TMP($J,TGLIST)
- S DS=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
- S HLOC=""
- F  S HLOC=$O(^TMP($J,HLOCL,HLOC)) Q:HLOC=""  D
- . S DATE=DS
- . F  S DATE=+$O(^AUPNVSIT("AHDP",HLOC,DATE),-1) Q:(DATE=0)!(DATE<BDT)  D
- .. S DFN=""
- .. F  S DFN=$O(^AUPNVSIT("AHDP",HLOC,DATE,DFN)) Q:DFN=""  D
- ... S SC=""
- ... F  S SC=$O(^AUPNVSIT("AHDP",HLOC,DATE,DFN,SC)) Q:SC=""  D
- .... S DAS=$O(^AUPNVSIT("AHDP",HLOC,DATE,DFN,SC,""))
- .... I '$$VAPSTAT^PXRMVSIT(DAS) Q
- .... S ^TMP($J,TGLIST,DFN,DATE,DAS)=HLOC
- ;Return the NOCC most recent for each patient.
- S DFN=0
- F  S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN=""  D
- . S DATE="",NFOUND=0
- . F  S DATE=$O(^TMP($J,TGLIST,DFN,DATE),-1) Q:(NFOUND=NOCC)!(DATE="")  D
- .. S DAS=""
- .. F  S DAS=$O(^TMP($J,TGLIST,DFN,DATE,DAS)) Q:(NFOUND=NOCC)!(DAS="")  D
- ... S NFOUND=NFOUND+1
- ... S ^TMP($J,PLIST,DFN,NFOUND)=DAS_U_DATE_U_^TMP($J,TGLIST,DFN,DATE,DAS)
- K ^TMP($J,TGLIST)
+ Q
+ ;
- ;=============================================
 GPLIST(FILENUM,SNODE,ITEM,PFINDPA,PLIST) ;Add to the patient list.
  ; Return the list in ^TMP($J,PLIST).
 …
  ;Set the finding search parameters.
  D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
- ;Ignore negative occurrence count, date reversal not allowed in
- ;patient lists.
  S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
  D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
  S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
+ S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC)
  ;Get a list of unique locations.
  S LNAME=$P(^PXRMD(810.9,ITEM,0),U,1)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLPAU.m

-              r628
+              r636
 PXRMLPAU ; SLC/AGP - Reminder Patient List ;09/06/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMLPAU ; SLC/AGP - Reminder Patient List ;07/29/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;Main entry point for PXRM PATIENT LIST
 …
+ Q
+ ;
 ADD ;add a user
+ADD ;add a users
  N CREAT,CNT,DIC,DIE,FDA,MSG,USER,Y
  S CREAT=$P($G(^PXRMXP(810.5,IEN,0)),U,7)
 …
  I $D(DIROUT) S DTOUT=1
  I $D(DTOUT)!($D(DUOUT)) Q
  I $G(Y)="" W !,"A level of control must be entered." H 2 Q
+ I $G(Y)="" W !,"A status must be enter" H 2 Q
  S YESNO=$E(Y(0))
  S FDA(810.54,"+2,"_IEN_",",.01)=USER
 …
 HELP(CALL) ;General help text routine
  N HTEXT
+ ;
  I CALL=1 D
+ .S HTEXT(1)="Select CO to copy the patient list.\\"
+ .S HTEXT(2)="Select COE to copy the patient list to an OE/RR Team.\\"
+ .S HTEXT(3)="Select DE to delete the patient list.\\"
+ .S HTEXT(4)="Select DSP to display the patient list.\\"
+ .S HTEXT(1)="Select CO to copy patient list."
+ .S HTEXT(2)="Select COE to copy patient list to OE/RR Team."
+ .S HTEXT(3)="Select CR to delete patient list."
+ .S HTEXT(4)="Select DSP to display patient list."
+ ;
  D HELP^PXRMEUT(.HTEXT)
+ Q
 …
  N CREAT,IND,LISTIEN,NODE
  I DUZ'=$P($G(^PXRMXP(810.5,IEN,0)),U,7) D  G PDELEX
  .W !,"Only the creator of this list can delete it." H 2
+ .W !,"Only the creator of this list can delete an user." H 2
  D EN^VALM2(XQORNOD(0))
  ;If there is no list quit.
 …
  .S LISTIEN=^TMP("PXRMLPAU",$J,"IDX",IND,IND)
  .S DA(1)=IEN,DA=LISTIEN,DIK="^PXRMXP(810.5,"_DA(1)_",40," D ^DIK
  .W !,"Patient list deleted"
+ .W !,"PATIENT DELETED"
+ ;
 PDELEX ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLPHS.m

-              r628
+              r636
 PXRMLPHS ; SLC/PJH,PKR - Run Health Summaries from Patient List ;03/26/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLPHS ; SLC/PJH,PKR - Run Health Summaries from Patient List ;08/08/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;External Ref DBIA #398
 …
+ ;
 QUE(HSIEN,PLNODE) ;Determine whether the report should be queued.
  N PXRMQUE,%ZIS,ZTDESC,ZTRTN,ZTSK,ZTSAVE
+ N PXRMQUE,RETZTSK,%ZIS,ZTDESC,ZTRTN,ZTSK,ZTSAVE
  S %ZIS="M"
  S ZTDESC="Patient List Health Summaries - print"
 …
  S ZTSAVE("HSIEN")=""
  S ZTSAVE("PLNODE")=""
+ S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,1)
+ S RETZTSK=1
+ S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.RETZTSK)
  S VALMBCK="R"
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLPP.m

-              r628
+              r636
 PXRMLPP ; SLC/PKR/PJH - Reminder Patient List Patients ;04/04/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLPP ; SLC/PKR/PJH - Reminder Patient List Patients ;01/06/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;Main entry point for PXRM PATIENT LIST
 START(IEN) ;
  N CDATE,CLASS,CREATOR,INDP,INTP,LDATA,LNAME,PXRMVIEW,SNAME,SOURCE,TYPE
+ N CDATE,CLASS,CREATOR,LDATA,LNAME,PXRMVIEW,SNAME,SOURCE,TYPE
  N VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
  ;Get Patient List record and associated data.
 …
  S CLASS=$P($G(^PXRMXP(810.5,IEN,100)),U)
  S CLASS=$S(CLASS="N":"National",CLASS="V":"VISN",1:"Local")
- S INDP=$P(LDATA,U,11)
- S INTP=$P(LDATA,U,12)
  ;Default view by name.
  S PXRMVIEW="N"
 …
+ Q
+ ;
+FRE(NUMBER,PNAME,DFN,DECEASED,TESTP,INST) ;Format  entry number, name, primary
+ ;station and deceased, test information.
+ N TEMP,TEXT,TNAME,TSOURCE
+ S TEXT=$$RJ^XLFSTR(NUMBER,5," ")
+ S TEXT=$$SETFLD^VALM1(PNAME,TEXT,"HEADER1")
+ S TEXT=TEXT_"  "_$$LJ^XLFSTR(DFN,15," ")
+ S TEMP=""
+ I DECEASED S TEMP=" (D)"
+ I TESTP S TEMP=" (T)"
+ I DECEASED,TESTP S TEMP=" (DP)"
+ S TEXT=TEXT_TEMP
+ I INST'="" S TEXT=$$SETFLD^VALM1(INST,TEXT,"HEADER3")
+ Q TEXT
+FRE(NUMBER,NAME,INST,DFN) ;Format  entry number, name and primary station
+ N TEMP,TNAME,TSOURCE
+ S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+ S TNAME=$E(NAME,1,30)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,32," ")
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(DFN,15," ")
+ I INST'="" S TEMP=TEMP_"  "_INST
+ Q TEMP
+ ;
 HDR ; Header code
+ N TEXT
+ S VALMHDR(1)="List Name: "_LNAME
+ S VALMHDR(1)="List Name: "_LNAME_" ("_VALMCNT_" patients)"
  S VALMHDR(2)=" Created: "_$$FMTE^XLFDT(CDATE,"5Z")
  S VALMHDR(2)=$$LJ^XLFSTR(VALMHDR(2),40)_"Creator: "_CREATOR
 …
  S VALMHDR(3)=$$LJ^XLFSTR(VALMHDR(3),40)_"Type: "_TYPE
  S VALMHDR(4)=" Source: "_SNAME
- S VALMHDR(5)=" Number of patients: "_VALMCNT
  S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
- S TEXT=""
- I INDP S TEXT=" (D=deceased)"
- I INTP S TEXT=" (T=test)"
- I INDP,INTP S TEXT=" (D=deceased, T=test)"
- S TEXT="DFN"_TEXT
- D CHGCAP^VALM("HEADER2",TEXT)
+ Q
+ ;
 …
  .;DBIA #10035
  .S PNAME=$P(^DPT(DFN,0),U,1)
- .I PNAME="" S PNAME=DFN_" does not exist"
  .S ^XTMP(PLNODE,PNAME)=DFN
  D HSI^PXRMLPHS(PLNODE)
 …
+ ;
 LIST(VALMCNT,IEN,INCINST) ;Build a list of patients.
  N DATA,DECEASED,DFN,IND,INST,NEXT,PNAME,SUB,TESTP
+ N DATA,DFN,IND,INST,NEXT,PNAME,SUB
  ;Build the ordered list.
  S IND=0,SUB="NAME"
 …
  .S DATA=$G(^PXRMXP(810.5,IEN,30,IND,0)) Q:DATA=""
  .S DFN=$P(DATA,U) Q:'DFN
- .S DECEASED=$P(DATA,U,4)
- .S TESTP=$P(DATA,U,5)
  .;#DBIA 10035
  .S PNAME=$P($G(^DPT(DFN,0)),U,1)
- .I PNAME="" S PNAME=DFN_" does not exist"
  .S INSTNUM=$P(DATA,U,2) S:INSTNUM="" INSTNUM="NONE"
  .S INST=$P(DATA,U,3)
 …
  .I INST="" S INST="NONE"
  .I PXRMVIEW="I" S SUB=INST
  .S ^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)=DECEASED_U_TESTP_U_INST
+ .S ^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)=INST
  ;Transfer to list manager array
  S SUB="",VALMCNT=0
 …
  ..S DFN=""
  ..F  S DFN=$O(^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)) Q:DFN=""  D
+ ...S DATA=^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)
+ ...S DECEASED=$P(DATA,U,1)
+ ...S TESTP=$P(DATA,U,2)
+ ...I INCINST S INST=$P(DATA,U,3)
+ ...I INCINST S INST=^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)
  ...S VALMCNT=VALMCNT+1
  ...S ^TMP("PXRMLPP",$J,VALMCNT,0)=$$FRE(VALMCNT,PNAME,DFN,DECEASED,TESTP,INST)
+ ...S ^TMP("PXRMLPP",$J,VALMCNT,0)=$$FRE(VALMCNT,PNAME,INST,DFN)
  ...S ^TMP("PXRMLPPI",$J,VALMCNT)=DFN
  K ^TMP("PXRMLPPA",$J)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLPU.m

-              r628
+              r636
 PXRMLPU ; SLC/PKR/PJH - Reminder Patient List ;10/11/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLPU ; SLC/PKR/PJH - Reminder Patient List ;08/07/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;Main entry point for PXRM PATIENT LIST
 …
+ ;
 BLDLIST ;
  N PLIST
+ N IEN,PLIST
  K ^TMP("PXRMLPU",$J)
  K ^TMP("PXRMLPUH",$J)
  S PLIST="PXRMLPU"
  D LIST(MODE,PLIST)
+ D LIST(MODE,PLIST,.IEN)
  S VALMCNT=+$G(^TMP("PXRMLPU",$J,"VALMCNT"))
+ F IND=1:1:VALMCNT D
+ .S ^TMP("PXRMLPU",$J,"IDX",IND,IND)=IEN(IND)
+ Q
+ ;
 …
+ Q
+ ;
+FORMAT(NUMBER,NAME,NODE) ;Format  entry number, name, source,
+ ;and date packed.
+ N ACCESS,DATE,COUNT,TEMP,TYPE
+ S DATE=$P(NODE,U,2),COUNT=$P(NODE,U,3)
+ S TYPE=$P(NODE,U,4),ACCESS=$P(NODE,U,5)
+ S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+ S NAME=$E(NAME,1,45)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(NAME,45," ")
+ S DATE=$$FMTE^XLFDT(DATE,2)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(DATE,17," ")
+ S TEMP=TEMP_"  "_$$RJ^XLFSTR(COUNT,6," ")
+ S TEMP=TEMP_"  "_$$RJ^XLFSTR(TYPE,4," ")
+ S TEMP=TEMP_"  "_$$RJ^XLFSTR(ACCESS,3," ")
+ Q TEMP
+ ;
 HDR ; Header code
  N NAME
 …
  N HTEXT
  I CALL=1 D
  .S HTEXT(1)="Select CO to copy the patient list.\\"
  .S HTEXT(2)="Select COE to copy the patient list to an OE/RR Team.\\"
  .S HTEXT(3)="Select DE to delete the patient list.\\"
  .S HTEXT(4)="Select DCD to display creation documentation.\\"
  .S HTEXT(5)="Select DSP to display the patient list.\\"
+ .S HTEXT(1)="Select CO to copy patient list."
+ .S HTEXT(2)="Select COE to copy patient list to OE/RR Team."
+ .S HTEXT(3)="Select CR to delete patient list."
+ .S HTEXT(4)="Select DCD to display creation documentation."
+ .S HTEXT(5)="Select DSP to display patient list."
  D HELP^PXRMEUT(.HTEXT)
+ Q
 …
+ Q
+ ;
+LIST(MODE,PLIST) ;Build a list of patient list entries.
+ N ACCESS,COUNT,DATA,DATE,IND,FMTSTR,FNAME,OUTPUT,NAME,NL,NUM
+ N STR,SUB,TYPE
+ S FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLRRC")
+LIST(MODE,PLIST,IEN) ;Build a list of patient list entries.
+ N ACCESS,COUNT,DATE,IND,FNAME,NAME,NODE,SUB,TYPE
  ;MODE=0 build list in alphabetical order
  ;MODE=1 build list by type of list.
  K ^TMP($J,PLIST),^TMP(PLIST,$J)
  S VALMCNT=0,NAME="",NUM=0,TYPE=""
+ S VALMCNT=0,NAME="",TYPE=""
  F  S NAME=$O(^PXRMXP(810.5,"B",NAME)) Q:NAME=""  D
  .S IND="" F  S IND=$O(^PXRMXP(810.5,"B",NAME,IND)) Q:'IND  D
  ..S DATA=$G(^PXRMXP(810.5,IND,0))
  ..S ACCESS=$$ACCESS(IND,DATA)
+ ..S NODE=$G(^PXRMXP(810.5,IND,0))
+ ..S ACCESS=$$ACCESS(IND,NODE)
  ..I ACCESS="N" Q
  ..S FNAME=$P($G(DATA),U),DATE=$P($G(DATA),U,4)
+ ..S FNAME=$P($G(NODE),U),DATE=$P($G(NODE),U,4)
  ..S COUNT=+$P($G(^PXRMXP(810.5,IND,30,0)),U,4)
  ..S TYPE=$P(DATA,U,8)
+ ..S TYPE=$P(NODE,U,8)
  ..S SUB=$S(MODE=0:"NAME",1:TYPE)
  ..S ^TMP($J,PLIST,SUB,FNAME)=IND_U_DATE_U_COUNT_U_TYPE_U_ACCESS
 …
  S SUB=""
  F  S SUB=$O(^TMP($J,PLIST,SUB),-1) Q:SUB=""  D
+ . S FNAME=""
+ . F  S FNAME=$O(^TMP($J,PLIST,SUB,FNAME)) Q:FNAME=""  D
+ .. S DATA=^TMP($J,PLIST,SUB,FNAME),NUM=NUM+1
+ .. S ^TMP("PXRMLPU",$J,"SEL",NUM)=$P(DATA,U,1)
+ .. S DATE=$P(DATA,U,2),DATE=$$FMTE^XLFDT(DATE,2)
+ .. S $P(DATA,U,2)=DATE
+ .. S STR=NUM_U_FNAME_U_$P(DATA,U,2,5)
+ .. D COLFMT^PXRMTEXT(FMTSTR,STR," ",.NL,.OUTPUT)
+ .. F IND=1:1:NL D
+ ... S VALMCNT=VALMCNT+1,^TMP(PLIST,$J,VALMCNT,0)=OUTPUT(IND)
+ ... S ^TMP("PXRMLPU",$J,"IDX",VALMCNT,NUM)=""
+ .S FNAME=""
+ .F  S FNAME=$O(^TMP($J,PLIST,SUB,FNAME)) Q:FNAME=""  D
+ ..S NODE=^TMP($J,PLIST,SUB,FNAME),VALMCNT=VALMCNT+1
+ ..S ^TMP(PLIST,$J,VALMCNT,0)=$$FORMAT(VALMCNT,FNAME,NODE)
+ ..S IEN(VALMCNT)=$P(NODE,U,1)
  S ^TMP(PLIST,$J,"VALMCNT")=VALMCNT
  K ^TMP($J,PLIST)
 …
  F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
  .;Get the patient list ien.
  .S LISTIEN=^TMP(SUB,$J,"SEL",IND)
  .D COPY^PXRMRUL1(LISTIEN)
+ .S LISTIEN=^TMP(SUB,$J,"IDX",IND,IND)
+ .D COPY^PXRMRULE(LISTIEN)
+ Q
+ ;
 …
  F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
  .;Get the patient list ien.
  .S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
+ .S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND)
  .S NODE=$G(^PXRMXP(810.5,LISTIEN,0))
  .S DELOK=$$LDELOK^PXRMEUT(LISTIEN)
  .I DELOK D DELETE^PXRMRUL1(LISTIEN) Q
+ .I DELOK D DELETE^PXRMRULE(LISTIEN) Q
  .E  D  Q
  ..W !,"In order to delete a list you must be the creator or a Reminder Manager!"
 …
  F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
  .;Get the patient list ien.
  .S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
+ .S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND)
  .S NODE=$G(^PXRMXP(810.5,LISTIEN,0))
  .S ACCESS=$$ACCESS^PXRMLPU(LISTIEN,NODE)
 …
  S IND=""
  F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
  .S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
+ .S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND)
  .D START^PXRMLPP(LISTIEN)
  D BLDLIST
 …
  .W $C(7),!,"Only one item number allowed." H 2
  .S VALMBCK="R"
  I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
  .W $C(7),!,SEL_" is not a valid item number." H 2
  .S VALMBCK="R"
+ ;
  ;Get the patient list ien
  S LISTIEN=^TMP("PXRMLPU",$J,"SEL",SEL)
+ S LISTIEN=^TMP("PXRMLPU",$J,"IDX",SEL,SEL)
  ;Get extract definition ien (if present)
  S EPIEN=$P($G(^PXRMXP(810.5,LISTIEN,0)),U,5)
 …
  S DIR("B")="DSP"
  S DIR("?")="Select from the codes displayed. For detailed help type ??"
  S DIR("??")=U_"D HELP^PXRMLPU(1)"
+ S DIR("??")=U_"D HELP^PXRMLPM(1)"
  D ^DIR K DIR
  I $D(DIROUT) S DTOUT=1
 …
+ ;
  ;Copy patient list
  I OPTION="CO" D COPY^PXRMRUL1(LISTIEN)
+ I OPTION="CO" D COPY^PXRMRULE(LISTIEN)
  Q:$D(DUOUT)!$D(DTOUT)
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLRM.m

-              r628
+              r636
 PXRMLRM ; SLC/PJH/PKR - List Rule Management ; 09/06/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLRM ; SLC/PJH/PKR - List Rule Management ; 05/15/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;Main entry point for PXRM LIST RULE MANAGEMENT
 …
  N HTEXT
  I CALL=1 D
  .S HTEXT(1)="Select DE to display or edit a rule.\\"
  .S HTEXT(2)="Select ED to edit a rule.\\"
+ .S HTEXT(1)="Select DE to display or edit a rule."
+ .S HTEXT(2)="Select ED to edit a rule"
+ ;
  I CALL=2 D
+ .S HTEXT(1)="Select F to edit term based finding rules.\\"
+ .S HTEXT(2)="Select P to edit patient list based finding rules.\\"
+ .S HTEXT(3)="Select R to edit reminder rules.\\"
+ .S HTEXT(4)="Select S to edit rule sets. A rule set may contain"
+ .S HTEXT(5)="any of the following:\\"
+ .S HTEXT(6)=" finding list rules, patient list rules, reminder rules\\"
+ .S HTEXT(7)="These component list rules must be created before the rule set"
+ .S HTEXT(8)="can be constructed."
+ .S HTEXT(1)=" Select F to edit term based finding rules."
+ .S HTEXT(2)=" Select P to edit patient list based finding rules."
+ .S HTEXT(3)=" Select R to edit reminder rules."
+ .S HTEXT(4)=" Select S to edit rule sets. A rule set may contain either "
+ .S HTEXT(5)="finding list rules or patient list rules or both. These "
+ .S HTEXT(6)="component list rules must be created before the rule set "
+ .S HTEXT(7)="can be constructed."
+ ;
  D HELP^PXRMEUT(.HTEXT)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMMH.m

-              r628
+              r636
 PXRMMH ; SLC/PKR - Handle mental health findings. ;11/23/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMMH ; SLC/PKR - Handle mental health findings. ;04/05/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;=======================================================
 …
  D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST)
+ Q
+ ;
  ;=======================================================
 EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate mental
 …
+ ;
  ;=======================================================
 GETDATA(DASP,FIEVT) ;Return the data for a MH Administrations entry.
+GETDATA(DAS,FIEVT) ;Return the data for a Psych Instrument Patient entry.
  ;Some tests require the YSP key in order to get a score.
+ N DAS,DATA,IND,SCALE
+ S DAS=$P(DASP,"S",1)
+ S SCALE=+$P(DASP,"S",2)
+ ;DBIA #5043
+ D ENDAS71^YTQPXRM6(.DATA,DAS)
+ I $G(DATA(1))="[ERROR]" Q
+ I SCALE=0 S SCALE=+$O(DATA("SI",""))
+ S FIEVT("MH TEST")=$P(DATA(2),U,3)
+ S IND=0
+ F  S IND=$O(DATA("SI",IND)) Q:IND=""  S FIEVT("S",IND)=$P(DATA("SI",IND),U,3,4)
+ S IND=0
+ F  S IND=$O(DATA("R",IND)) Q:IND=""  S FIEVT("R",IND)=$P(DATA("R",IND),U,6)
+ I $D(DATA("SI",SCALE)) S FIEVT("VALUE")=FIEVT("S",SCALE),FIEVT("SCALE NAME")=$P(DATA("SI",SCALE),U,2)
+ N DASP,IND,SCALE,YSDATA
+ ;DBIA #4442
+ S DASP=$P(DAS,"S",1)
+ S SCALE=$P(DAS,"S",2)
+ D ENDAS^YTAPI10(.YSDATA,DASP)
+ I $G(YSDATA(0))="[ERROR]" Q
+ S FIEVT("MH TEST")=$P(YSDATA(2),U,3)
+ I FIEVT("MH TEST")["GAF" S FIEVT("RATING")=$P(YSDATA(3),U,2) Q
+ ;If no scale is specified use the first set of results.
+ S IND=$S(SCALE="":6,1:SCALE+5)
+ S FIEVT("YSDATA")=$G(YSDATA(IND))
+ S FIEVT("SCALE NAME")=$P(FIEVT("YSDATA"),U,2)
+ S (FIEVT("RAW SCORE"),FIEVT("VALUE"))=$P(FIEVT("YSDATA"),U,3)
+ S FIEVT("TRANSFORMED SCORE")=$P(FIEVT("YSDATA"),U,4)
+ Q
+ ;
  ;=======================================================
 MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+ N DATE,IND,JND,MHTEST,NOUT,SCALE,SNAME,SCORE,TEXTOUT
+ S MHTEST="Mental Health Test: "_IFIEVAL("MH TEST")_" = "
+ N DATE,IND,JND,MHTEST,NAME,NOUT,RATING,RSCORE,SCORE,TEXTOUT,TSCORE
+ S MHTEST=IFIEVAL("MH TEST")
+ ;Remove the dashes surrounding the name.
+ S MHTEST=$TR(MHTEST,"-","")
+ S NAME="Mental Health Test: "_MHTEST_" = "
  S IND=0
  F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
  . S DATE="("_$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE"))_")"
  . S TEMP=MHTEST_DATE
  . S SNAME=$G(IFIEVAL(IND,"SCALE NAME"))
  . I SNAME'="" S TEMP=TEMP_" scale: "_SNAME_" -"
  . S SCORE=$G(IFIEVAL(IND,"VALUE"))
  . I SCORE'="" S TEMP=TEMP_"  raw score: "_$P(SCORE,U,1)_", transformed score: "_$P(SCORE,U,2)
+ . S DATE=IFIEVAL(IND,"DATE")
+ . S RSCORE=$G(IFIEVAL(IND,"RAW SCORE"))
+ . S TSCORE=$G(IFIEVAL(IND,"TRANSFORMED SCORE"))
+ . S RATING=$G(IFIEVAL(IND,"RATING"))
+ . S SCORE=$S(RATING'="":RATING,TSCORE'="":TSCORE,RSCORE'="":RSCORE,1:"")
+ . S TEMP=NAME_SCORE_" ("_$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE"))_")"
  . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
  . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
 …
 OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
  ;maintenance output.
  N IND,JND,MHTEST,NOUT,SCALE,SNAME,SCORE,TEXTOUT
+ N DATE,IND,JND,MHTEST,NOUT,RATING,RSCORE,TEXTOUT,TSCORE
  S MHTEST=IFIEVAL("MH TEST")
+ ;Remove the dashes surrounding the name.
+ S MHTEST=$TR(MHTEST,"-","")
  S NLINES=NLINES+1
  S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Mental Health Test: "_MHTEST
  S IND=0
  F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S DATE=IFIEVAL(IND,"DATE")
  . S TEMP=$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE"))
+ . S SNAME=$G(IFIEVAL(IND,"SCALE NAME"))
+ . I SNAME'="" S TEMP=TEMP_" scale: "_SNAME_" -"
+ . S SCORE=$G(IFIEVAL(IND,"VALUE"))
+ . I SCORE'="" S TEMP=TEMP_"  raw score: "_$P(SCORE,U,1)_", transformed score: "_$P(SCORE,U,2)
+ . S RSCORE=$G(IFIEVAL(IND,"RAW SCORE"))
+ . I RSCORE'="" S TEMP=TEMP_" raw score - "_RSCORE
+ . S TSCORE=$G(IFIEVAL(IND,"TRANSFORMED SCORE"))
+ . I TSCORE'="" S TEMP=TEMP_"; transformed score - "_TSCORE
+ . S RATING=$G(IFIEVAL(IND,"RATING"))
+ . I RATING'="" S TEMP=TEMP_" Rating: "_RATING
  . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
  . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
 …
  ;=======================================================
 SCHELP(MHIEN) ;Xecutable help for MH SCALE
  N DATA,IND,JND,NUM,SCALE,SNUM
+ N IND,JND,NUM,SCALE,TEMP,TEMP1
  I MHIEN=0 D  Q
  . S SCALE(1)="This is not a valid Mental Health finding, selecting an MH scale does"
  . S SCALE(2)="not make sense"
  . D EN^DDIOL(.SCALE)
+ ;DBIA #5053
+ D SCALES^YTQPXRM5(.DATA,MHIEN)
+ I DATA(1)="ERROR" D  Q
+ . S SCALE(1)="There are no scales for this test."
+ . D EN^DDIOL(.SCALE)
+ S SCALE(1)="Valid scales are:"
+ S SCALE(2)="SCALE NUMBER  SCALE NAME"
+ S SCALE(3)="------------------------"
+ S IND=0,JND=3
+ F  S IND=$O(DATA("S",IND)) Q:IND=""  D
+ S SCALE(1)="SCALE NUMBER  SCALE NAME"
+ S SCALE(2)="------------------------"
+ S IND=0
+ S JND=2
+ F  S IND=$O(^YTT(601,MHIEN,"S",IND)) Q:+IND=0  D
+ . S TEMP=^YTT(601,MHIEN,"S",IND,0)
  . S JND=JND+1
+ . S NUM=6-$L(IND)
+ . S SCALE(JND)=$$INSCHR^PXRMEXLC(NUM," ")_(IND)_"        "_$P(DATA("S",IND),U,1)
+ . S TEMP1=$P(TEMP,U,1)
+ . S NUM=6-$L(TEMP1)
+ . S SCALE(JND)=$$INSCHR^PXRMEXLC(NUM," ")_TEMP1_"        "_$P(TEMP,U,2)
  D EN^DDIOL(.SCALE)
+ Q
+ ;
  ;=======================================================
-SCHELPD(DA) ;Xecutable help for MH SCALE in Result Group file 801.41
- N MHIEN
- S MHIEN=+$P($G(^PXRMD(801.41,DA,50)),U)
- D SCHELP^PXRMMH(MHIEN)
+ Q
- ;=======================================================
 SCHELPF ;Xecutable help for MH SCALE in 811.9 findings.
  N FIND0,MHIEN
  S FIND0=^PXD(811.9,DA(1),20,DA,0)
  I FIND0["YTT(601.71" S MHIEN=$P(FIND0,";",1)
+ I FIND0["YTT(601" S MHIEN=$P(FIND0,";",1)
  E  S MHIEN=0
  D SCHELP(MHIEN)
 …
  N MHIEN,TFIND0
  S TFIND0=^PXRMD(811.5,DA(1),20,DA,0)
  I TFIND0["YTT(601.71" S MHIEN=$P(TFIND0,";",1)
+ I TFIND0["YTT(601" S MHIEN=$P(TFIND0,";",1)
  E  S MHIEN=0
  D SCHELP(MHIEN)
 …
+ ;
  ;=======================================================
-SCNAME(TEST,SCNUM) ;Given the test ien and scale number return the
- ;scale name.
- N DATA,SCNAME
- D SCALES^YTQPXRM5(.DATA,TEST)
- Q $G(DATA("S",SCNUM))
+ ;
- ;=======================================================
 SEVALFI(DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ;
  N FIEV,FINDING,IND,YS,DATA
+ N FIEV,FINDING,IND,YS,YSDATA
  S YS("CODE")=ITEM,YS("DFN")=DFN
  S YS("BEGIN")=BDT,YS("END")=EDT
  ;PTTEST^YTQPXRM2 does not understand "*" for a limit so use 99.
+ ;YTAPI10A does not understand "*" for a limit so use 99.
  I NGET="*" S NGET=99
  S YS("LIMIT")=$S(SDIR=-1:NGET,1:-NGET)
  ;DBIA #5035
  D PTTEST^YTQPXRM2(.DATA,.YS)
  S NFOUND=$P(DATA(1),U,2)
+ ;DBIA #4458
+ D PTTEST^YTAPI10A(.YSDATA,.YS)
+ S NFOUND=$P(YSDATA(1),U,2)
  I NFOUND=0 Q
  F IND=1:1:NFOUND S FLIST(IND)=DATA(IND+1)
+ F IND=1:1:NFOUND S FLIST(IND)=YSDATA(IND+1)
+ Q
+ ;
 …
  N YS
  ;YTAPI10A does not understand "*" for a limit so use 99.
- ;OCCUR^YTQPXRM1 does not understand "*" for a limit so use 99.
  I NOCC="*" S NOCC=99
  S YS("CODE")=ITEM,YS("BEGIN")=BDT,YS("END")=EDT,YS("LIMIT")=NOCC
  ;DBIA #5034
  D OCCUR^YTQPXRM1(PLIST,.YS)
+ ;DBIA #4458
+ D OCCUR^YTAPI10A(PLIST,.YS)
+ Q
+ ;
 …
 VSCALE(X,FIND0) ;Make sure that the mental health scale is valid.
  ;Either the scale number or the scale name can be used.
  N DATA,IND,MHIEN,MHTEST,SCALE,VALID
+ N MHIEN,MHTEST,SCALE,VALID
  S MHTEST=$P(FIND0,U,1)
  S MHIEN=$P(MHTEST,";",1)
  D SCALES^YTQPXRM5(.DATA,MHIEN)
  I +X>0 S VALID=$S($D(DATA("S",X)):1,1:0)
+ I +X>0 D  Q VALID
+ . S VALID=$S($D(^YTT(601,MHIEN,"S",X)):1,1:0)
  E  D
+ . S IND=1,VALID=0
+ . F  S IND=$O(DATA("S",IND)) Q:(VALID)!(IND="")  D
+ .. I X=$P(DATA("S",IND),U,1) S VALID=1 Q
+ I 'VALID D EN^DDIOL(X_" is not a valid scale for this test!")
+ I $O(DATA(""),-1)>20 H 1
+ . S SCALE=$O(^YTT(601,MHIEN,"S","C",X,""))
+ . S VALID=$S(SCALE="":0,1:1)
  Q VALID
+ ;
- ;=======================================================
-VSCALED(X,DA) ;Make sure that the mental health scale is valid for a result
- ;group.
- I X="" Q 1
- ;Do not execute as part of a verify fields.
- I $G(DIUTIL)="VERIFY FIELDS" Q 1
- ;Do not execute as part of exchange.
- I $G(PXRMEXCH) Q 1
- N MHTEST
- S MHTEST=$P($G(^PXRMD(801.41,DA,50)),U)
- Q $$VSCALE(X,MHTEST)
+ ;
  ;=======================================================
 …
  Q $$VSCALE(X,TFIND0)
+ ;
- ;=======================================================
-WARN ;Warn the user that they must select a scale if they intend to use
- ;a condition.
- W !,"Remember that the score is returned as raw score^transformed score,"
- W !,"so if your Condition uses the raw score use +V or $P(V,U,1) and if"
- W !,"it uses the transformed score use $P(V,U,2)."
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMMST.m

-              r628
+              r636
 PXRMMST ; SLC/PKR - Routines for dealing with MST. ;03/29/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMMST ; SLC/PKR - Routines for dealing with MST. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;Use of DGMSTAPI supported by DBIA #2716.
  ;====================================================
 …
  . I TERMIEN="" Q
  . D TERM^PXRMLDR(TERMIEN,.TERMARR)
  . D EVALPL^PXRMTERL(.FINDPA,.TERMARR,INDEX)
+ . D EVALPL^PXRMTERM(.FINDPA,.TERMARR,INDEX)
  . S DFN=0
  . F  S DFN=+$O(^TMP($J,INDEX,1,DFN)) Q:DFN=0  D

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMOUTC.m

-              r628
+              r636
 PXRMOUTC ; SLC/PKR - Clinical Maintenance output. ;07/06/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMOUTC ; SLC/PKR - Clinical Maintenance output. ;10/07/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;================================================
 CM(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL) ;Prepare the
  ;clinical maintenance output.
  N IND,JND,FIDATA,FINDING,FLIST,FTYPE
+ N IND,FIDATA,FINDING,FLIST,FTYPE
  N HDR,NHDR,IFIEVAL,LIST,NFLINES,NTXT,NUM
  N TEMP,TEXT
 …
  .. I '$D(FIDATA(FINDING)) Q
  .. K IFIEVAL
+ .. ;I FIEVAL(FINDING) M IFIEVAL=FIEVAL(FINDING)
+ .. ;E  S IFIEVAL=0
+ .. I FIEVAL(FINDING) D
+ ... M IFIEVAL=FIEVAL(FINDING)
+ ...;Remove any false occurrences so they are not displayed.
+ ... S JND=0
+ ... F  S JND=+$O(IFIEVAL(JND)) Q:JND=0  K:'IFIEVAL(JND) IFIEVAL(JND)
+ .. I FIEVAL(FINDING) M IFIEVAL=FIEVAL(FINDING)
  .. E  S IFIEVAL=0
  ..;If the finding is false all we need to do is process the not found
 …
  I FTYPE="PXRMD(811.4," D OUTPUT^PXRMCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
  I FTYPE="RAMIS(71," D OUTPUT^PXRMRAD(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
  I FTYPE="YTT(601.71," D OUTPUT^PXRMMH(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="YTT(601," D OUTPUT^PXRMMH(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMOUTM.m

-              r628
+              r636
 PXRMOUTM ; SLC/PKR - MyHealtheVet output. ;07/06/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMOUTM ; SLC/PKR - MyHealtheVet output. ;10/12/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;================================================
 …
  I FTYPE="PXRMD(811.4," D MHVOUT^PXRMCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
  I FTYPE="RAMIS(71," D MHVOUT^PXRMRAD(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
  I FTYPE="YTT(601.71," D MHVOUT^PXRMMH(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="YTT(601," D MHVOUT^PXRMMH(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ Q
+ ;
 …
 MHVD(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL,WEB) ;Prepare the
  ;MyHealtheVet detailed output.
  N IND,JND,FIDATA,FINDING,FLIST,FTYPE
+ N IND,FIDATA,FINDING,FLIST,FTYPE
  N HDR,NHDR,IFIEVAL,LIST,NFLINES,NTXT,NUM
  N TEXT
 …
  .. I '$D(FIDATA(FINDING)) Q
  .. K IFIEVAL
+ .. ;I FIEVAL(FINDING) M IFIEVAL=FIEVAL(FINDING)
+ .. ;E  S IFIEVAL=0
+ .. I FIEVAL(FINDING) D
+ ... M IFIEVAL=FIEVAL(FINDING)
+ ...;Remove any false occurrences so they are not displayed.
+ ... S JND=0
+ ... F  S JND=+$O(IFIEVAL(JND)) Q:JND=0  K:'IFIEVAL(JND) IFIEVAL(JND)
+ .. I FIEVAL(FINDING) M IFIEVAL=FIEVAL(FINDING)
  .. E  S IFIEVAL=0
  ..;Output the found/not found text for the finding.

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMP9E.m

r628	r636
18	18	D BM(" Code Set Update message fix (Remedy Ticket 175985)"),M(" ")
19	19	N DA,DIC,DIQ,DR,PXRMB,PXRMBLD,PXRMBLDS,PXRMERR,PXRMHF,PXRMI,PXRML,PXRMPAT,PXRMPN,PXRMREQ,PXRMS,PXRMT,PXRMU,PXRMV,PXRMVER,X
20		K XPDABORT,XPDQUIT S U="^",PXRMREQ="LEX2.025;LEX2.027;~~LEX2.032;LEX2.046;~~ICD18.011;ICPT6.016;PXRM2.04"
	20	K XPDABORT,XPDQUIT S U="^",PXRMREQ="LEX2.025;LEX2.027;ICD18.011;ICPT6.016;PXRM2.04"
21	21	S PXRMBLD="LEX2.049",PXRMBLDS="LEX2.049;ICD18.028;ICPT6.034;PXRM2.09",PXRMHF="LEX_2_49.KID"
22	22	K PXRMERR D:+($$UR)'>0 ET("User not defined (DUZ)") I $D(PXRMERR) D ABRT Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPARS.m

-              r628
+              r636
 PXRMPARS ; SLC/PJH - Edit PXRM(800 reminder parameters. ;04/02/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPARS ; SLC/PJH - Edit PXRM(800 reminder parameters. ;06/14/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;called by protocol PXRM EDIT SITE DISCLAIMER
 …
  D ^DIE
  D FORMAT^PXRMDISC
+ Q
+ ;
-MH(DA) ;Edit MH default Question Value
- Q:'$$LOCK(DA)
- N DIC,DIE,DR,Y
- ;Edit
- S DIE="^PXRM(800,",DR=17
- D ^DIE
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPDR.m

-              r628
+              r636
 PXRMPDR ;SLC/AGP,PKR - Patient List Demographic report main routine ;11/16/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPDR ;SLC/AGP,PKR - Patient List Demographic report main routine ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
 EN(PLIEN) ; -- main entry point for PXRM PATIENT LIST DEMOGRAPHIC
+ N ARRAY,DC,DDATA,DELIM,DTOUT,DUOUT
+ N ADDDATA,APPDATA,ARRAY,BACK,CNT,DC,DEMDATA,DELIM,DIC,DIR,DTOUT,DUOUT
+ N ELIGDATA,IEN,INPDATA
+ N FINDDATA,NAME,NODE,PFACDATA,PTIEN
+ N QUIT,REMDATA
+ N X,Y,YESNO
  W @IOF
  K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J)
  S DELIM=0
+ S BACK=0,DELIM=0,QUIT=0
 OPTION ;
  W !,"Select the items to include on the report."
 ADDSEL D ADDSEL^PXRMPDRS(.DDATA,"ADD")
+ADDSEL D ADDSEL^PXRMPDRS(.ADDDATA)
  I $D(DTOUT)!$D(DUOUT) Q
 APPSEL D APPSEL^PXRMPDRS(.DDATA,"APP")
+APPSEL D APPSEL^PXRMPDRS(.APPDATA)
  I $D(DTOUT)!$D(DUOUT) G ADDSEL
 DEMSEL D DEMSEL^PXRMPDRS(.DDATA,"DEM")
+DEMSEL D DEMSEL^PXRMPDRS(.DEMDATA)
  I $D(DTOUT)!$D(DUOUT) G APPSEL
 PFACSEL S DDATA("PFAC",0)=$$ASKYN^PXRMEUT("N","Include the patient's preferred facility")
+PFACSEL S PFACDATA(0)=$$ASKYN^PXRMEUT("N","Include the patient's preferred facility")
  I $D(DTOUT)!$D(DUOUT) G DEMSEL
  S DDATA("PFAC","LEN")=$S(DDATA("PFAC",0)=1:1,1:0)
 ELIGSEL D ELIGSEL^PXRMPDRS(.DDATA,"ELIG")
+ S PFACDATA("LEN")=$S(PFACDATA(0)=1:1,1:0)
+ELIGSEL D ELIGSEL^PXRMPDRS(.ELIGDATA)
  I $D(DTOUT)!$D(DUOUT) G PFACSEL
 DATASEL D DATASEL^PXRMPDRS(PLIEN,.DDATA,"FIND")
+DATASEL D DATASEL^PXRMPDRS(PLIEN,.FINDDATA)
  I $D(DTOUT)!$D(DUOUT) G ELIGSEL
 INPSEL D INPSEL^PXRMPDRS(.DDATA,"INP")
+INPSEL D INPSEL^PXRMPDRS(.INPDATA)
  I $D(DTOUT)!$D(DUOUT) G DATASEL
 REMDATA D REMSEL^PXRMPDRS(PLIEN,.DDATA,"REM")
+REMDATA D REMSEL^PXRMPDRS(PLIEN,.REMDATA)
  I $D(DTOUT)!$D(DUOUT) G INPSEL
  S DELIM=$$ASKYN^PXRMEUT("Y","Delimited Report:")
  I $D(DTOUT)!$D(DUOUT) G REMDATA
  S DC=$S(DELIM:$$DELIMSEL^PXRMXSD,1:U)
+ I DELIM S DC=$$DELIMSEL^PXRMXSD
  I $D(DTOUT)!$D(DUOUT) G OPTION
 DEVICE ;
  N DESC,DIR,PXRMQUE,RTN,SAVE,%ZIS
+ N DIR,PXRMQUE,%ZIS,ZTDESC,ZTRTN,ZTSAVE
  S %ZIS="M"
  S DESC="Patient List Demographic Report"
  S RTN="GETPDATA^PXRMPDR(DELIM,DC,PLIEN,.DDATA)"
  S SAVE("DELIM")="",SAVE("DC")="",SAVE("PLIEN")=""
  S SAVE("DDATA(")=""
  S PXRMQUE=$$DEVICE^PXRMXQUE(RTN,DESC,.SAVE,.%ZIS,1)
  I PXRMQUE'="" G EXIT
+ S ZTDESC="Patient List Demographic"
+ S ZTRTN="GETDATA^PXRMPDR(DELIM,PLIEN,.DEMDATA,.PFACDATA,.ADDDATA,.INPDATA,.APPDATA,.FINDDATA,.REMDATA)"
+ S ZTSAVE("*")=""
+ S PXRMQUE=0
+ S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.ZTSK)
+ I PXRMQUE=1 G EXIT
  I $D(DTOUT)!$D(DUOUT) G EXIT
+ ;
  S DIR(0)="E" D ^DIR
 EXIT D KVA^VADPT
 …
+ Q
+ ;
 GETPDATA(DELIM,DC,PLIEN,DDATA) ;
+GETDATA(DELIM,PLIEN,DEMDATA,PFACDATA,ADDDATA,INPDATA,APPDATA,FINDDATA,REMDATA) ;
  N DATA,DATE,DCREAT,DFN,DTYPE,ERRMSG
  N GETADD,GETAPP,GETDEM,GETELIG,GETFIND,GETINP,GETREM
 …
  S LISTNAME=$P(^PXRMXP(810.5,PLIEN,0),U,1)
  S DCREAT=$P(^PXRMXP(810.5,PLIEN,0),U,4)
  S GETDEM=$S(DDATA("DEM","LEN")>0:1,1:0)
  S GETADD=$S(DDATA("ADD","LEN")>0:1,1:0)
  S GETINP=$S(DDATA("INP","LEN")>0:1,1:0)
  S GETELIG=$S(DDATA("ELIG","LEN")>0:1,1:0)
  S GETAPP=$S(DDATA("APP","LEN")>0:1,1:0)
  S GETFIND=$S(DDATA("FIND","LEN")>0:1,1:0)
  S GETREM=$S(DDATA("REM","LEN")>0:1,1:0)
+ S GETDEM=$S(DEMDATA("LEN")>0:1,1:0)
+ S GETADD=$S(ADDDATA("LEN")>0:1,1:0)
+ S GETINP=$S(INPDATA("LEN")>0:1,1:0)
+ S GETELIG=$S(ELIGDATA("LEN")>0:1,1:0)
+ S GETAPP=$S(APPDATA("LEN")>0:1,1:0)
+ S GETFIND=$S(FINDDATA("LEN")>0:1,1:0)
+ S GETREM=$S(REMDATA("LEN")>0:1,1:0)
  S IEN=0
  F  S IEN=+$O(^PXRMXP(810.5,PLIEN,30,IEN)) Q:IEN=0  D
 …
  .. N VADM
  .. D DEM^VADPT
  .. F IND=1:1:DDATA("DEM","LEN") D
  ... S JND=$P(DDATA("DEM"),",",IND)
  ... S KND=0
  ... F  S KND=$O(DDATA("DEM",JND,KND)) Q:KND=""  D
  .... S PIECE=$P(DDATA("DEM",JND,KND),U,2)
+ .. F IND=1:1:DEMDATA("LEN") D
+ ... S JND=$P(DEMDATA,",",IND)
+ ... S KND=0
+ ... F  S KND=$O(DEMDATA(JND,KND)) Q:KND=""  D
+ .... S PIECE=$P(DEMDATA(JND,KND),U,2)
  .... S TDATA=$P(VADM(KND),U,PIECE)
  .... S LND=""
 …
  ..... I TDATA'="" S TDATA=TDATA_"~"
  ..... S TDATA=TDATA_$P(VADM(KND,LND),U,PIECE)
  .... I KND=2,'DDATA("DEM","FULLSSN") S TDATA=$E(TDATA,8,11)
  .... S $P(PDATA,U,KND)=TDATA
  .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"DEM")=PDATA,PDATA=""
  . I DDATA("PFAC",0)=1 D
+ .... I KND=2,'DEMDATA("FULLSSN") S TDATA=$E(TDATA,8,11)
+ .... S $P(PDATA,U,KND)=TDATA
+ .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"DEMDATA")=PDATA,PDATA=""
+ . I PFACDATA(0)=1 D
  ..;DBIA #1850
  .. S TDATA=$$GET1^DIQ(2,DFN,27.02,"E","","ERRMSG")
  .. I TDATA="" S TDATA="NONE"
  .. S ^TMP("PXRMPLD",$J,DFN,"PFAC")=TDATA
+ .. S ^TMP("PXRMPLD",$J,DFN,"PFACDATA")=TDATA
  . I GETADD D
  .. N VAPA
  .. D ADD^VADPT
  .. F IND=1:1:DDATA("ADD","LEN") D
  ... S JND=$P(DDATA("ADD"),",",IND)
  ... S KND=0
  ... F  S KND=$O(DDATA("ADD",JND,KND)) Q:KND=""  D
  .... S PIECE=$P(DDATA("ADD",JND,KND),U,2)
+ .. F IND=1:1:ADDDATA("LEN") D
+ ... S JND=$P(ADDDATA,",",IND)
+ ... S KND=0
+ ... F  S KND=$O(ADDDATA(JND,KND)) Q:KND=""  D
+ .... S PIECE=$P(ADDDATA(JND,KND),U,2)
  .... S TDATA=$P(VAPA(KND),U,PIECE)
  .... S $P(PDATA,U,KND)=TDATA
  .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ADD")=PDATA,PDATA=""
+ .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ADDDATA")=PDATA,PDATA=""
  . I GETINP D
  .. N VAIP
  .. D INP^VADPT
  .. F IND=1:1:DDATA("INP","LEN") D
  ... S JND=$P(DDATA("INP"),",",IND)
  ... S KND=0
  ... F  S KND=$O(DDATA("INP",JND,KND)) Q:KND=""  D
  .... S PIECE=$P(DDATA("INP",JND,KND),U,2)
+ .. F IND=1:1:INPDATA("LEN") D
+ ... S JND=$P(INPDATA,",",IND)
+ ... S KND=0
+ ... F  S KND=$O(INPDATA(JND,KND)) Q:KND=""  D
+ .... S PIECE=$P(INPDATA(JND,KND),U,2)
  .... S TDATA=$P(VAIN(KND),U,PIECE)
  .... S $P(PDATA,U,KND)=TDATA
  .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"INP")=PDATA,PDATA=""
+ .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"INPDATA")=PDATA,PDATA=""
  . I GETELIG D
  .. N VAEL
  .. D ELIG^VADPT
  .. F IND=1:1:DDATA("ELIG","LEN") D
  ... S JND=$P(DDATA("ELIG"),",",IND)
  ... S KND=0
  ... F  S KND=$O(DDATA("ELIG",JND,KND)) Q:KND=""  D
  .... S PIECE=$P(DDATA("ELIG",JND,KND),U,2)
+ .. F IND=1:1:ELIGDATA("LEN") D
+ ... S JND=$P(ELIGDATA,",",IND)
+ ... S KND=0
+ ... F  S KND=$O(ELIGDATA(JND,KND)) Q:KND=""  D
+ .... S PIECE=$P(ELIGDATA(JND,KND),U,2)
  .... S TDATA=$P(VAEL(KND),U,PIECE)
  .... I KND=4 S TDATA=$S(TDATA=1:"YES",1:"NO")
  .... S $P(PDATA,U,KND)=TDATA
  .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ELIG")=PDATA,PDATA=""
+ .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ELIGDATA")=PDATA,PDATA=""
  . D KVA^VADPT
  . I GETREM D
  .. S IND=0
  .. F  S IND=$O(DDATA("REM","IEN",IND)) Q:IND=""  D
+ .. F  S IND=$O(REMDATA("IEN",IND)) Q:IND=""  D
  ... S PDATA=$G(^PXRMXP(810.5,PLIEN,30,IEN,"REM",IND,0))
  ... I PDATA="" Q
  ... S RIEN=$P(PDATA,U,1)
  ... S ^TMP("PXRMPLD",$J,DFN,"REM",RIEN)=PDATA,PDATA=""
+ ... S ^TMP("PXRMPLD",$J,DFN,"REMDATA",RIEN)=PDATA,PDATA=""
  . I GETFIND D
  .. N DL
  .. F IND=1:1:DDATA("FIND","LEN") D
  ... S JND=$P(DDATA("FIND"),",",IND)
  ... S DTYPE=DDATA("FIND",JND,JND)
+ .. F IND=1:1:FINDDATA("LEN") D
+ ... S JND=$P(FINDDATA,",",IND)
+ ... S DTYPE=FINDDATA(JND,JND)
  ... S KND=$O(^PXRMXP(810.5,PLIEN,30,IEN,"DATA","B",DTYPE,""))
  ... S DL=$S(KND="":0,1:$L(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U))
  ... S DATA=$S(KND="":"",1:$P(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U,2,DL))
  ... S ^TMP("PXRMPLD",$J,DFN,"FIND",JND)=DATA
+ ... S ^TMP("PXRMPLD",$J,DFN,"FINDDATA",JND)=DATA
  ;Get appointment data for all patients on the list.
  I GETAPP D
 …
  . S ARRAY(1)=DT,ARRAY(3)="I;R"
  . S ARRAY(4)="^TMP($J,""PXRMPL""",ARRAY("FLDS")=""
  . F IND=1:1:DDATA("APP","LEN") D
  .. S JND=$P(DDATA("APP"),",",IND)
+ . F IND=1:1:APPDATA("LEN") D
+ .. S JND=$P(APPDATA,",",IND)
  .. S KND=0
  .. F  S KND=$O(DDATA("APP",JND,KND)) Q:KND=""  S ARRAY("FLDS")=ARRAY("FLDS")_KND_";"
+ .. F  S KND=$O(APPDATA(JND,KND)) Q:KND=""  S ARRAY("FLDS")=ARRAY("FLDS")_KND_";"
  . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
  . S IND=0
 …
  . I COUNT=-1 D  Q
  .. D APPERR^PXRMPDRS
  .. S DDATA("APP","ERROR")=""
+ .. S APPDATA("ERROR")=""
  .. K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
  . F IND=1:1:COUNT D
 …
  ..... S TDATA=$P(TDATA,U,2),TDATA=$P(TDATA,";",2)
  ..... S PDATA=PDATA_U_TDATA
  ..... S ^TMP("PXRMPLD",$J,DFN,"APP",KND)=PDATA
+ ..... S ^TMP("PXRMPLD",$J,DFN,"APPDATA",KND)=PDATA
  . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
  I DELIM=1 D DELIMPR^PXRMPDRP(DC,PLIEN,.DDATA)
  I DELIM=0 D REGPR^PXRMPDRP(PLIEN,.DDATA)
+ I DELIM=1 D DELIMPR^PXRMPDRP(DC,PLIEN,.ADDDATA,.APPDATA,.DEMDATA,.FINDDATA,.INPDATA,.PFACDATA,.REMDATA)
+ I DELIM=0 D REGPR^PXRMPDRP(PLIEN,.ADDDATA,.APPDATA,.DEMDATA,.FINDDATA,.INPDATA,.PFACDATA,.REMDATA)
+ Q
+ ;
 …
+ ;
 PAGE ;
  I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
+ I ($E(IOST)="C")&(IO=IO(0)) D
  .S DIR(0)="E"
  .W !
 …
  W:$D(IOF) @IOF
  S PAGE=PAGE+1
  I ($E(IOST,1,2)="C-")&(IO=IO(0)) W @IOF
+ Q
+ ;
+ I $E(IOST)="C",IO=IO(0) W @IOF
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPDRP.m

-              r628
+              r636
 PXRMPDRP ;SLC/AGP,PKR - Patient List Demographic report print routine ;11/16/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPDRP ;SLC/AGP,PKR - Patient List Demographic report print routine ;06/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
 ADDTXT(TEXT) ;Accumulate text in ^TMP.
 …
+ Q
+ ;
 APPHDR(DC,DDATA,SUB) ;Build the appointment header.
  I DDATA(SUB,"LEN")'>0 Q
+APPHDR(DC,APPDATA) ;Build the appointment header.
+ I APPDATA("LEN")'>0 Q
  N HDR,IND,JND,KND,LND,TEMP
  S IND=0,HDR=""
  F IND=1:1:DDATA(SUB,"MAX") D
  . F JND=1:1:DDATA(SUB,"LEN") D
  .. S KND=$P(DDATA(SUB),",",JND)
+ F IND=1:1:APPDATA("MAX") D
+ . F JND=1:1:APPDATA("LEN") D
+ .. S KND=$P(APPDATA,",",JND)
  .. S LND=""
  .. F  S LND=$O(DDATA(SUB,KND,LND)) Q:LND=""  D
  ... S TEMP=$P(DDATA(SUB,KND,LND),U,1)
+ .. F  S LND=$O(APPDATA(KND,LND)) Q:LND=""  D
+ ... S TEMP=$P(APPDATA(KND,LND),U,1)
  ... S HDR=HDR_TEMP_IND_DC
  S DDATA(SUB,"HDR")=HDR
+ Q
+ ;
 APPPRINT(DFN,DDATA,SUB) ;Print appointment data.
+ S APPDATA("HDR")=HDR
+ Q
+ ;
+APPPRINT(DFN,APPDATA) ;Print appointment data.
  N CLINIC,COUNT,DATE,HDR,IND,JND,KND,LINE,PCLINIC,PDATE,TEMP
  S (PCLINIC,PDATE)=0
  F IND=1:1:DDATA(SUB,"LEN") D
  . S JND=$P(DDATA(SUB),",",IND)
+ F IND=1:1:APPDATA("LEN") D
+ . S JND=$P(APPDATA,",",IND)
  . I JND=1 S PDATE=1
  . I JND=2 S PCLINIC=1
  S HDR=""
  I PDATE S HDR=" "_$P(DDATA(SUB,1,1),U,1)
  I PCLINIC S HDR=HDR_"   "_$P(DDATA(SUB,2,2),U,1)
+ I PDATE S HDR=" "_$P(APPDATA(1,1),U,1)
+ I PCLINIC S HDR=HDR_"   "_$P(APPDATA(2,2),U,1)
  D ADDTXT(" ")
  D ADDTXT("Appointment Data")
  D ADDTXT(HDR)
  S COUNT=0
  F  S COUNT=$O(^TMP("PXRMPLD",$J,DFN,"APP",COUNT)) Q:COUNT=""  D
  . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"APP",COUNT))
+ F  S COUNT=$O(^TMP("PXRMPLD",$J,DFN,"APPDATA",COUNT)) Q:COUNT=""  D
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"APPDATA",COUNT))
  . S LINE=""
  . I PDATE S LINE=LINE_$P(TEMP,U,1)
 …
+ Q
+ ;
 DELIMHDR(DC,DDATA,SUB) ;Build the delimited header for a data type.
  I DDATA(SUB,"LEN")'>0 Q
+DELIMHDR(DC,DATA) ;Build the delimited header for a data type.
+ I DATA("LEN")'>0 Q
  N HDR,IND,JND,KND,LND,MAX,TEMP
  S IND=0,HDR=""
  F IND=1:1:DDATA(SUB,"LEN") D
  . S JND=$P(DDATA(SUB),",",IND)
+ F IND=1:1:DATA("LEN") D
+ . S JND=$P(DATA,",",IND)
  . S KND=""
  . F  S KND=$O(DDATA(SUB,JND,KND)) Q:KND=""  D
  .. S TEMP=$P(DDATA(SUB,JND,KND),U,1)
  .. S MAX=$P(DDATA(SUB,JND,KND),U,3)
+ . F  S KND=$O(DATA(JND,KND)) Q:KND=""  D
+ .. S TEMP=$P(DATA(JND,KND),U,1)
+ .. S MAX=$P(DATA(JND,KND),U,3)
  .. I MAX="" S HDR=HDR_TEMP_DC
  .. I +MAX>0 F LND=1:1:MAX S HDR=HDR_TEMP_LND_DC
  S DDATA(SUB,"HDR")=HDR
+ Q
+ ;
 DELIMPR(DC,PLIEN,DDATA) ;
+ S DATA("HDR")=HDR
+ Q
+ ;
+DELIMPR(DC,PLIEN,ADDDATA,APPDATA,DEMDATA,FINDDATA,INPDATA,PFACDATA,REMDATA) ;
  ;Print the delimited report.
  N DATALIST,DFN,IND,NDT,PNAME
  S NDT=0
+ I DDATA("ADD","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="ADD"
+ I DDATA("APP","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="APP"
+ I DDATA("DEM","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="DEM"
+ I DDATA("ELIG","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="ELIG"
+ I DDATA("FIND","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="FIND"
+ I DDATA("INP","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="INP"
+ I DDATA("PFAC","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="PFAC"
+ I DDATA("REM","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="REM"
+ S DATALIST(0)=NDT
+ I ADDDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="ADDDATA"
+ I APPDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="APPDATA"
+ I DEMDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="DEMDATA"
+ I ELIGDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="ELIGDATA"
+ I FINDDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="FINDDATA"
+ I INPDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="INPDATA"
+ I PFACDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="PFACDATA"
+ I REMDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="REMDATA"
  D TITLE(PLIEN,1)
  ;Create the delimited header.
+ ;Output the delimited header.
  F IND=1:1:NDT D
  . I DATALIST(IND)="ADD" D DELIMHDR(DC,.DDATA,"ADD") Q
  . I DATALIST(IND)="APP" D APPHDR(DC,.DDATA,"APP") Q
  . I DATALIST(IND)="DEM" D DELIMHDR(DC,.DDATA,"DEM") Q
  . I DATALIST(IND)="ELIG" D DELIMHDR(DC,.DDATA,"ELIG") Q
  . I DATALIST(IND)="FIND" D DELIMHDR(DC,.DDATA,"FIND") Q
  . I DATALIST(IND)="INP" D DELIMHDR(DC,.DDATA,"INP") Q
  . I DATALIST(IND)="PFAC" D PFACHDR(.DDATA,"PFAC")
  . I DATALIST(IND)="REM" D REMHDR(DC,.DDATA,"REM") Q
  D DELTITLE(DC,.DATALIST,.DDATA)
+ . I DATALIST(IND)="ADDDATA" D DELIMHDR(DC,.ADDDATA) Q
+ . I DATALIST(IND)="APPDATA" D APPHDR(DC,.APPDATA) Q
+ . I DATALIST(IND)="DEMDATA" D DELIMHDR(DC,.DEMDATA) Q
+ . I DATALIST(IND)="ELIGDATA" D DELIMHDR(DC,.ELIGDATA) Q
+ . I DATALIST(IND)="FINDDATA" D DELIMHDR(DC,.FINDDATA) Q
+ . I DATALIST(IND)="INPDATA" D DELIMHDR(DC,.INPDATA) Q
+ . I DATALIST(IND)="PFACDATA" D PFACHDR(.PFACDATA)
+ . I DATALIST(IND)="REMDATA" D REMHDR(DC,.REMDATA) Q
+ D DELTITLE(DC,.ADDDATA,.APPDATA,.DEMDATA,.FINDDATA,.INPDATA,.PFACDATA,.REMDATA)
  S PNAME=":"
  F  S PNAME=$O(^TMP("PXRMPLN",$J,PNAME)) Q:PNAME=""  D
 …
  .. W !,PNAME_DC
  .. F IND=1:1:NDT D
  ... I DATALIST(IND)="ADD" D PDELDATA(DFN,DC,DATALIST(IND),.DDATA,"ADD") Q
  ... I DATALIST(IND)="APP" D PAPPDATA(DFN,DC,.DDATA,"APP") Q
  ... I DATALIST(IND)="DEM" D PDELDATA(DFN,DC,DATALIST(IND),.DDATA,"DEM") Q
  ... I DATALIST(IND)="ELIG" D PDELDATA(DFN,DC,DATALIST(IND),.DDATA,"ELIG") Q
  ... I DATALIST(IND)="FIND" D PFINDATA(DFN,DC,.DDATA,"FIND") Q
  ... I DATALIST(IND)="INP" D PDELDATA(DFN,DC,DATALIST(IND),.DDATA,"INP") Q
  ... I DATALIST(IND)="PFAC" D PFACDATA(DFN,.DDATA,"PFAC") Q
  ... I DATALIST(IND)="REM" D PREMDATA(DFN,DC,.DDATA,"REM") Q
+ ... I DATALIST(IND)="ADDDATA" D PDELDATA(DFN,DC,DATALIST(IND),.ADDDATA) Q
+ ... I DATALIST(IND)="APPDATA" D PAPPDATA(DFN,DC,.APPDATA) Q
+ ... I DATALIST(IND)="DEMDATA" D PDELDATA(DFN,DC,DATALIST(IND),.DEMDATA) Q
+ ... I DATALIST(IND)="ELIGDATA" D PDELDATA(DFN,DC,DATALIST(IND),.ELIGDATA) Q
+ ... I DATALIST(IND)="FINDDATA" D PFINDATA(DFN,DC,.FINDDATA) Q
+ ... I DATALIST(IND)="INPDATA" D PDELDATA(DFN,DC,DATALIST(IND),.INPDATA) Q
+ ... I DATALIST(IND)="PFACDATA" D PFACDATA(DFN,.PFACDATA) Q
+ ... I DATALIST(IND)="REMDATA" D PREMDATA(DFN,DC,.REMDATA) Q
  .. W "\\"
+ Q
+ ;
+DELTITLE(DC,DATALIST,DDATA) ;Combine all the headers to create the delimited title.
+DELTITLE(DC,ADDDATA,APPDATA,DEMDATA,FINDDATA,INPDATA,PFACDATA,REMDATA) ;Combine
+ ;all the headers to create the delimited title.
  W !,"PATIENT"_DC
+ N IND
+ F IND=1:1:DATALIST(0) W DDATA(DATALIST(IND),"HDR")
+ W $G(ADDDATA("HDR"))
+ W $G(APPDATA("HDR"))
+ W $G(DEMDATA("HDR"))
+ W $G(ELIGDATA("HDR"))
+ W $G(FINDDATA("HDR"))
+ W $G(INPDATA("HDR"))
+ W $G(PFACDATA("HDR"))
+ W $G(REMDATA("HDR"))
  W "\\"
+ Q
+ ;
 FINDPR(DFN,DDATA,SUB) ;Print finding information.
+FINDPR(DFN,FINDDATA) ;Print finding information.
  N IND,JND,LINE,TEMP
  D ADDTXT(" ")
  S LINE="Finding Data"
  D ADDTXT(LINE)
  F IND=1:1:DDATA(SUB,"LEN") D
  . S JND=$P(DDATA(SUB),",",IND)
  . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"FIND",JND))
+ F IND=1:1:FINDDATA("LEN") D
+ . S JND=$P(FINDDATA,",",IND)
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"FINDDATA",JND))
  . I TEMP="" Q
  . S LINE=" "_$P(DDATA(SUB,JND,JND),U,1)_": "_TEMP
+ . S LINE=" "_$P(FINDDATA(JND,JND),U,1)_": "_TEMP
  . D ADDTXT(LINE)
+ Q
 …
+ ;
 PAGE ;
  I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
+ I ($E(IOST)="C")&(IO=IO(0)) D
  . N DIR
  . S DIR(0)="E"
 …
  I $D(DUOUT)!$D(DTOUT) Q
  W:$D(IOF) @IOF
  I ($E(IOST,1,2)="C-")&(IO=IO(0)) W @IOF
+ Q
+ ;
 PAPPDATA(DFN,DC,DDATA,SUB) ;Print the delimited appointment data.
+ I $E(IOST)="C",IO=IO(0) W @IOF
+ Q
+ ;
+PAPPDATA(DFN,DC,APPDATA) ;Print the delimited appointment data.
  N IND,JND,KND,LINE,LND,PIECE,TEMP
  I DDATA(SUB,"LEN")'>0 Q
+ I APPDATA("LEN")'>0 Q
  S LINE=""
  F IND=1:1:DDATA(SUB,"MAX") D
  . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"APP",IND))
  . F JND=1:1:DDATA(SUB,"LEN") D
  .. S KND=$P(DDATA(SUB),",",JND)
+ F IND=1:1:APPDATA("MAX") D
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"APPDATA",IND))
+ . F JND=1:1:APPDATA("LEN") D
+ .. S KND=$P(APPDATA,",",JND)
  .. S LND=""
  .. F  S LND=$O(DDATA(SUB,KND,LND)) Q:LND=""  D
  ... S PIECE=$P(DDATA(SUB,KND,KND),U,2)
+ .. F  S LND=$O(APPDATA(KND,LND)) Q:LND=""  D
+ ... S PIECE=$P(APPDATA(KND,KND),U,2)
  ... S LINE=LINE_$P(TEMP,U,PIECE)_DC
  W LINE
+ Q
+ ;
 PDELDATA(DFN,DC,DTYPE,DDATA,SUB) ;Print the delimited data.
+PDELDATA(DFN,DC,DTYPE,DATA) ;Print the delimited data.
  N IND,JND,KND,LINE,LND,TEMP,TTEMP
+ I DATA("LEN")'>0 Q
  S TEMP=$G(^TMP("PXRMPLD",$J,DFN,DTYPE))
  S LINE=""
  F IND=1:1:DDATA(DTYPE,"LEN") D
  . S JND=$P(DDATA(DTYPE),",",IND)
+ F IND=1:1:DATA("LEN") D
+ . S JND=$P(DATA,",",IND)
  . S KND=""
  . F  S KND=$O(DDATA(DTYPE,JND,KND)) Q:KND=""  D
  .. S MAX=$P(DDATA(DTYPE,JND,KND),U,3)
+ . F  S KND=$O(DATA(JND,KND)) Q:KND=""  D
+ .. S MAX=$P(DATA(JND,KND),U,3)
  .. I MAX="" S LINE=LINE_$P(TEMP,U,KND)_DC Q
  .. I +MAX>1 S TTEMP=$P(TEMP,U,KND) F LND=1:1:MAX S LINE=LINE_$P(TTEMP,"~",LND)_DC
 …
+ Q
+ ;
 PFACHDR(DDATA,SUB) ;Build the preferred facility header.
  I DDATA(SUB,0)=1 S DDATA(SUB,"HDR")="PATIENT'S PREFERRED FACILITY"
+ Q
+ ;
 PFACDATA(DFN,DDATA,SUB) ;Print the patient's preferred facility data, delimited.
  I DDATA(SUB,0)=0 Q
  W ^TMP("PXRMPLD",$J,DFN,"PFAC")
+ Q
+ ;
 PFACPR(DFN,DDATA,SUB) ;Print the patient's preferred facility.
  I DDATA(SUB,0)=0 Q
+PFACHDR(PFACDATA) ;Build the preferred facility header.
+ I PFACDATA(0)=1 S PFACDATA("HDR")="PATIENT'S PREFERRED FACILITY"
+ Q
+ ;
+PFACDATA(DFN,PFACDATA) ;Print the patient's preferred facility data, delimited.
+ I PFACDATA(0)=0 Q
+ W ^TMP("PXRMPLD",$J,DFN,"PFACDATA")
+ Q
+ ;
+PFACPR(DFN,PFACDATA) ;Print the patient's preferred facility.
+ I PFACDATA(0)=0 Q
  D ADDTXT("Patient's Preferred Facility")
  D ADDTXT(" "_$G(^TMP("PXRMPLD",$J,DFN,"PFAC")))
+ Q
+ ;
 PFINDATA(DFN,DC,DDATA,SUB) ;Print the finding data.
+ D ADDTXT(" "_$G(^TMP("PXRMPLD",$J,DFN,"PFACDATA")))
+ Q
+ ;
+PFINDATA(DFN,DC,FINDDATA) ;Print the finding data.
  N IND,JND,LINE,TEMP
  I DDATA(SUB,"LEN")'>0 Q
+ I FINDDATA("LEN")'>0 Q
  S LINE=""
  F IND=1:1:DDATA(SUB,"LEN") D
  . S JND=$P(DDATA(SUB),",",IND)
  . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"FIND",JND))
+ F IND=1:1:FINDDATA("LEN") D
+ . S JND=$P(FINDDATA,",",IND)
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"FINDDATA",JND))
  . S LINE=LINE_TEMP_DC
  W LINE
+ Q
+ ;
 PREMDATA(DFN,DC,DDATA,SUB) ;Print the reminder data.
+PREMDATA(DFN,DC,REMDATA) ;Print the reminder data.
  N IND,JND,LINE,TEMP
  I DDATA(SUB,"LEN")'>0 Q
+ I REMDATA("LEN")'>0 Q
  S LINE=""
  F IND=1:1:DDATA(SUB,"LEN") D
  . S JND=$P(DDATA(SUB),",",IND)
  . S LINE=LINE_DDATA(SUB,"RNAME",JND)_DC
  . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"REM",DDATA(SUB,"IEN",JND)))
+ F IND=1:1:REMDATA("LEN") D
+ . S JND=$P(REMDATA,",",IND)
+ . S LINE=LINE_REMDATA("RNAME",JND)_DC
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"REMDATA",REMDATA("IEN",JND)))
  . S LINE=LINE_$P(TEMP,U,2)_DC_$P(TEMP,U,3)_"^"_$P(TEMP,U,4)_DC
  W LINE
+ Q
+ ;
 REGPR(PLIEN,DDATA,SUB) ;
+REGPR(PLIEN,ADDDATA,APPDATA,DEMDATA,FINDDATA,INPDATA,PFACDATA,REMDATA) ;
  ;Print the regular report..
  N DATATYPE,DFN,PNAME,LINCNT
 …
  .. S DATATYPE=""
  .. F  S DATATYPE=$O(^TMP("PXRMPLD",$J,DFN,DATATYPE)) Q:DATATYPE=""  D
  ... I DATATYPE="ADD" D VADPTPR(DFN,"Address Data",DATATYPE,.DDATA,"ADD") Q
  ... I DATATYPE="APP" D APPPRINT(DFN,.DDATA,"APP") Q
  ... I DATATYPE="DEM" D VADPTPR(DFN,"Demographic Data",DATATYPE,.DDATA,"DEM") Q
  ... I DATATYPE="ELIG" D VADPTPR(DFN,"Eligibility Data",DATATYPE,.DDATA,"ELIG") Q
  ... I DATATYPE="FIND" D FINDPR(DFN,.DDATA,"FIND") Q
  ... I DATATYPE="INP" D VADPTPR(DFN,"Inpatient Data",DATATYPE,.DDATA,"INP") Q
  ... I DATATYPE="PFAC" D PFACPR(DFN,.DDATA,"PFAC") Q
  ... I DATATYPE="REM" D REMPR(DFN,.DDATA,"REM") Q
+ ... I DATATYPE="ADDDATA" D VADPTPR(DFN,"Address Data",DATATYPE,.ADDDATA) Q
+ ... I DATATYPE="APPDATA" D APPPRINT(DFN,.APPDATA) Q
+ ... I DATATYPE="DEMDATA" D VADPTPR(DFN,"Demographic Data",DATATYPE,.DEMDATA) Q
+ ... I DATATYPE="ELIGDATA" D VADPTPR(DFN,"Eligibility Data",DATATYPE,.ELIGDATA) Q
+ ... I DATATYPE="FINDDATA" D FINDPR(DFN,.FINDDATA) Q
+ ... I DATATYPE="INPDATA" D VADPTPR(DFN,"Inpatient Data",DATATYPE,.INPDATA) Q
+ ... I DATATYPE="PFACDATA" D PFACPR(DFN,.PFACDATA) Q
+ ... I DATATYPE="REMDATA" D REMPR(DFN,.REMDATA) Q
  D OUTPUT
  K ^TMP("PXRMPDEM",$J)
+ Q
+ ;
 REMHDR(DC,DDATA,SUB) ;Build the reminder data delimited header.
+REMHDR(DC,REMDATA) ;Build the reminder data delimited header.
  N HDR,IND,JND
  S HDR=""
  F IND=1:1:DDATA(SUB,"LEN") D
  . S JND=$P(DDATA(SUB),",",IND)
+ F IND=1:1:REMDATA("LEN") D
+ . S JND=$P(REMDATA,",",IND)
  . S HDR=HDR_"REMINDER"_JND_DC_"STATUS"_JND_DC_"DUE DATE"_JND_DC_"LAST DONE"_JND_DC
  S DDATA(SUB,"HDR")=HDR
+ Q
+ ;
 REMPR(DFN,DDATA,SUB) ;Print reminder status information.
+ S REMDATA("HDR")=HDR
+ Q
+ ;
+REMPR(DFN,REMDATA) ;Print reminder status information.
  N DUE,IND,JND,LAST,LINE,NSP,STATUS,TEMP
  D ADDTXT(" ")
  S LINE="Reminder:"_$$INSCHR^PXRMEXLC(27," ")_"--STATUS--  --DUE DATE--  --LAST DONE--"
  D ADDTXT(LINE)
  F IND=1:1:DDATA(SUB,"LEN") D
  . S JND=$P(DDATA(SUB),",",IND)
  . S RIEN=DDATA(SUB,"IEN",JND)
  . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"REM",RIEN))
+ F IND=1:1:REMDATA("LEN") D
+ . S JND=$P(REMDATA,",",IND)
+ . S RIEN=REMDATA("IEN",JND)
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"REMDATA",RIEN))
  . I TEMP="" Q
  . S STATUS=$P(TEMP,U,2)
  . S DUE=$P(TEMP,U,3),DUE=$$EDATE^PXRMDATE(DUE)
  . S LAST=$P(TEMP,U,4),LAST=$$EDATE^PXRMDATE(LAST)
  . S NSP=38-$L(DDATA(SUB,"RNAME",JND))
  . S LINE=DDATA(SUB,"RNAME",JND)_$$INSCHR^PXRMEXLC(NSP," ")_STATUS
+ . S NSP=38-$L(REMDATA("RNAME",JND))
+ . S LINE=REMDATA("RNAME",JND)_$$INSCHR^PXRMEXLC(NSP," ")_STATUS
  . S NSP=54-$L(LINE)-($L(DUE)/2)
  . S LINE=LINE_$$INSCHR^PXRMEXLC(NSP," ")_DUE
 …
+ Q
+ ;
 VADPTPR(DFN,DNAME,DTYPE,DDATA,SUB) ;Print data returned by a VADPT call.
+VADPTPR(DFN,DNAME,DTYPE,DATA) ;Print data returned by a VADPT call.
  N IND,JND,KND,LINE,LND,MAX,TEMP,TTEMP
  D ADDTXT(" ")
  D ADDTXT(DNAME)
  S TEMP=$G(^TMP("PXRMPLD",$J,DFN,DTYPE))
  F IND=1:1:DDATA(SUB,"LEN") D
  . S JND=$P(DDATA(SUB),",",IND)
+ F IND=1:1:DATA("LEN") D
+ . S JND=$P(DATA,",",IND)
  . S KND=""
  . F  S KND=$O(DDATA(SUB,JND,KND)) Q:KND=""  D
+ . F  S KND=$O(DATA(JND,KND)) Q:KND=""  D
  .. S TTEMP=$P(TEMP,U,KND)
  .. S MAX=+$P(DDATA(SUB,JND,KND),U,3)
+ .. S MAX=+$P(DATA(JND,KND),U,3)
  .. I MAX=0 S MAX=1
  .. F LND=1:1:MAX D
  ... S LINE=" "_$P(DDATA(SUB,JND,KND),U,1)_": "_$P(TTEMP,"~",LND)
+ ... S LINE=" "_$P(DATA(JND,KND),U,1)_": "_$P(TTEMP,"~",LND)
  ... D ADDTXT(LINE)
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPDRS.m

-              r628
+              r636
 PXRMPDRS ;SLC/PKR - Patient List Demographic Report data selection. ;03/22/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPDRS ;SLC/PKR - Patient List Demographic Report data selection. ;07/18/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
 ADDSEL(DATA,SUB) ;Let the user select the address information they want.
+ADDSEL(ADDDATA) ;Let the user select the address information they want.
  N ADDLIST,LIST
  S ADDLIST("A",1)=" 1 - CURRENT ADDRESS",DATA(SUB,1,1)="STREET ADDRESS #1"_U_1
  S DATA(SUB,1,2)="STREET ADDRESS #2"_U_1,DATA(SUB,1,3)="STREET ADDRESS #3"_U_1
  S DATA(SUB,1,4)="CITY"_U_1,DATA(SUB,1,5)="STATE"_U_2,DATA(SUB,1,6)="ZIP"_U_1
  S DATA(SUB,1,7)="COUNTY"_U_2
  S ADDLIST("A",2)=" 2 - PHONE NUMBER",DATA(SUB,2,8)="PHONE NUMBER"_U_1
+ S ADDLIST("A",1)=" 1 - CURRENT ADDRESS",ADDDATA(1,1)="STREET ADDRESS #1"_U_1
+ S ADDDATA(1,2)="STREET ADDRESS #2"_U_1,ADDDATA(1,3)="STREET ADDRESS #3"_U_1
+ S ADDDATA(1,4)="CITY"_U_1,ADDDATA(1,5)="STATE"_U_2,ADDDATA(1,6)="ZIP"_U_1
+ S ADDDATA(1,7)="COUNTY"_U_2
+ S ADDLIST("A",2)=" 2 - PHONE NUMBER",ADDDATA(2,8)="PHONE NUMBER"_U_1
  S ADDLIST("A")="Enter your selection(s)"
  S ADDLIST("?")="^D HELP^PXRMPDRS"
 …
  S LIST=$$SEL^PXRMPDRS(.ADDLIST,2)
  I $D(DTOUT)!$D(DUOUT) Q
  S DATA(SUB)=LIST
  S DATA(SUB,"LEN")=$L(LIST,",")-1
+ S ADDDATA=LIST
+ S ADDDATA("LEN")=$L(LIST,",")-1
+ Q
+ ;
 …
+ Q
+ ;
 APPSEL(DATA,SUB) ;Let the user select the appointment information they want.
+APPSEL(APPDATA) ;Let the user select the appointment information they want.
  ;The first subscript of APPDATA is the selection number and the
  ;the second subscript is the subscript where the data is returned
 …
  ;second piece is the piece of VAPA this is displayed.
  N APPLIST,LIST,MAX
  S APPLIST("A",1)=" 1 - APPOINTMENT DATE",DATA(SUB,1,1)="APPOINTMENT DATE"_U_1
  S APPLIST("A",2)=" 2 - CLINIC",DATA(SUB,2,2)="CLINIC"_U_2
+ S APPLIST("A",1)=" 1 - APPOINTMENT DATE",APPDATA(1,1)="APPOINTMENT DATE"_U_1
+ S APPLIST("A",2)=" 2 - CLINIC",APPDATA(2,2)="CLINIC"_U_2
  S APPLIST("A")="Enter your selection(s)"
  S APPLIST("?")="^D HELP^PXRMPDRS"
 …
  S LIST=$$SEL^PXRMPDRS(.APPLIST,2)
  I $D(DTOUT)!$D(DUOUT) Q
  S DATA(SUB)=LIST
  S DATA(SUB,"LEN")=$L(LIST,",")-1
  I DATA(SUB,"LEN")=0 Q
  S DATA(SUB,"MAX")=$$ASKNUM^PXRMEUT("Maximum number of appointments to display",1,25)
+ S APPDATA=LIST
+ S APPDATA("LEN")=$L(LIST,",")-1
+ I APPDATA("LEN")=0 Q
+ S APPDATA("MAX")=$$ASKNUM^PXRMEUT("Maximum number of appointments to display",1,25)
+ Q
+ ;
 DATASEL(LISTIEN,DATA,SUB) ; Build a list of data that is availble for
+DATASEL(LISTIEN,FINDDATA) ; Build a list of data that is availble for
  ;this patient list and let the user select what they want.
  N IND,DATALIST,DTYPE
 …
  F  S DTYPE=$O(^PXRMXP(810.5,LISTIEN,35,"B",DTYPE)) Q:DTYPE=""  D
  . S IND=IND+1,DATALIST("A",IND)=" "_IND_" - "_DTYPE
  . S DATA(SUB,IND,IND)=DTYPE
+ . S FINDDATA(IND,IND)=DTYPE
  ;If there is no data quit.
  I IND=0 S DATA(SUB,"LEN")=0 Q
+ I IND=0 S FINDDATA("LEN")=0 Q
  S DATALIST("A")="Enter your selections(s)"
  S DATALIST("?")="^D HELP^PXRMPDRS"
 …
  S LIST=$$SEL^PXRMPDRS(.DATALIST,IND)
  I $D(DTOUT)!$D(DUOUT) Q
  S DATA(SUB)=LIST
  S DATA(SUB,"LEN")=$L(LIST,",")-1
+ S FINDDATA=LIST
+ S FINDDATA("LEN")=$L(LIST,",")-1
+ Q
+ ;
 DEMSEL(DATA,SUB) ;Let the user select the demographic information they want.
  ;The first subscript of DATA is the selection number and the
+DEMSEL(DEMDATA) ;Let the user select the demographic information they want.
+ ;The first subscript of DEMDATA is the selection number and the
  ;the second subscript is the subscript where the data is returned
  ;in VADM. The first piece of DEMDATA is the name of the data and the
  ;second piece is the piece of VADM this is displayed.
  N DEMLIST,DTOUT,DUOUT,IND,ITEM,JND,KND,LIST,TEMP
  S DEMLIST("A",1)=" 1 - SSN",DATA(SUB,1,2)="SSN"_U_2
  S DEMLIST("A",2)=" 2 - DATE OF BIRTH",DATA(SUB,2,3)="DOB"_U_2
  S DEMLIST("A",3)=" 3 - AGE",DATA(SUB,3,4)="AGE"_U_1
  S DEMLIST("A",4)=" 4 - SEX",DATA(SUB,4,5)="SEX"_U_2
  S DEMLIST("A",5)=" 5 - DATE OF DEATH",DATA(SUB,5,6)="DOD"_U_2
  S DEMLIST("A",6)=" 6 - REMARKS",DATA(SUB,6,7)="REMARKS"_U_1
  S DEMLIST("A",7)=" 7 - HISTORIC RACE",DATA(SUB,7,8)="HISTORIC RACE"_U_2
  S DEMLIST("A",8)=" 8 - RELIGION",DATA(SUB,8,9)="RELIGION"_U_2
  S DEMLIST("A",9)=" 9 - MARITAL STATUS",DATA(SUB,9,10)="MARTIAL STATUS"_U_2
  S DEMLIST("A",10)="10 - ETHNICITY",DATA(SUB,10,11)="ETHNICITY"_U_2
  S DEMLIST("A",11)="11 - RACE",DATA(SUB,11,12)="RACE"_U_2
+ S DEMLIST("A",1)=" 1 - SSN",DEMDATA(1,2)="SSN"_U_2
+ S DEMLIST("A",2)=" 2 - DATE OF BIRTH",DEMDATA(2,3)="DOB"_U_2
+ S DEMLIST("A",3)=" 3 - AGE",DEMDATA(3,4)="AGE"_U_1
+ S DEMLIST("A",4)=" 4 - SEX",DEMDATA(4,5)="SEX"_U_2
+ S DEMLIST("A",5)=" 5 - DATE OF DEATH",DEMDATA(5,6)="DOD"_U_2
+ S DEMLIST("A",6)=" 6 - REMARKS",DEMDATA(6,7)="REMARKS"_U_1
+ S DEMLIST("A",7)=" 7 - HISTORIC RACE",DEMDATA(7,8)="HISTORIC RACE"_U_2
+ S DEMLIST("A",8)=" 8 - RELIGION",DEMDATA(8,9)="RELIGION"_U_2
+ S DEMLIST("A",9)=" 9 - MARITAL STATUS",DEMDATA(9,10)="MARTIAL STATUS"_U_2
+ S DEMLIST("A",10)="10 - ETHNICITY",DEMDATA(10,11)="ETHNICITY"_U_2
+ S DEMLIST("A",11)="11 - RACE",DEMDATA(11,12)="RACE"_U_2
  S DEMLIST("A")="Enter your selection(s)"
  S DEMLIST("?")="^D HELP^PXRMPDRS"
 …
  S LIST=$$SEL^PXRMPDRS(.DEMLIST,11)
  I $D(DTOUT)!$D(DUOUT) Q
  S DATA(SUB)=LIST
  S DATA(SUB,"LEN")=$L(LIST,",")-1
  F IND=1:1:DATA(SUB,"LEN") D
+ S DEMDATA=LIST
+ S DEMDATA("LEN")=$L(LIST,",")-1
+ F IND=1:1:DEMDATA("LEN") D
  . S JND=$P(LIST,",",IND)
  . S KND=$O(DATA(SUB,JND,""))
  . S TEMP=$P(DATA(SUB,JND,KND),U,1)
+ . S KND=$O(DEMDATA(JND,""))
+ . S TEMP=$P(DEMDATA(JND,KND),U,1)
  . I TEMP="SSN" D
  .. N FULLSSN
  .. D SSN^PXRMXSD(.FULLSSN)
  .. S DATA(SUB,"FULLSSN")=$S($G(FULLSSN)="Y":1,1:0)
  . I $D(DTOUT)!$D(DUOUT) S IND=DATA(SUB,"LEN")+1 Q
  . I TEMP="ETHNICITY" S $P(DATA(SUB,10,11),U,3)=$$ASKNUM^PXRMEUT("Maximum number of ethnicity entries to display",1,10)
  . I TEMP="RACE" S $P(DATA(SUB,11,12),U,3)=$$ASKNUM^PXRMEUT("Maximum number of race entries to display",1,10)
+ .. S DEMDATA("FULLSSN")=$S($G(FULLSSN)="Y":1,1:0)
+ . I $D(DTOUT)!$D(DUOUT) S IND=DEMDATA("LEN")+1 Q
+ . I TEMP="ETHNICITY" S $P(DEMDATA(10,11),U,3)=$$ASKNUM^PXRMEUT("Maximum number of ethnicity entries to display",1,10)
+ . I TEMP="RACE" S $P(DEMDATA(11,12),U,3)=$$ASKNUM^PXRMEUT("Maximum number of race entries to display",1,10)
  I $D(DTOUT)!$D(DUOUT) K DTOUT,DUOUT G DSEL
+ Q
+ ;
 ELIGSEL(DATA,SUB) ;Let the user select the eligibility data they want.
+ELIGSEL(ELIGDATA) ;Let the user select the eligibility data they want.
  ;The first subscript of ELIGDATA is the selection number and the
  ;the second subscript is the subscript where the data is returned
 …
  ;second piece is the piece of VAEL this is displayed.
  N ELIGLIST,ITEM,LIST
  S ELIGLIST("A",1)=" 1 - PRIMARY ELGIBILITY CODE",DATA(SUB,1,1)="PRIMARY ELGIBILITY CODE"_U_2
  S ELIGLIST("A",2)=" 2 - PERIOD OF SERVICE",DATA(SUB,2,2)="PERIOD OF SERVICE"_U_2
  S ELIGLIST("A",3)=" 3 - % SERVICE CONNECTED",DATA(SUB,3,3)="% SERVICE CONNECTED"_U_2
  S ELIGLIST("A",4)=" 4 - VETERAN",DATA(SUB,4,4)="VETERAN"_U_1
  S ELIGLIST("A",5)=" 5 - TYPE",DATA(SUB,5,6)="TYPE"_U_2
  S ELIGLIST("A",6)=" 6 - ELIGIBILITY STATUS",DATA(SUB,6,8)="ELIGIBILITY STATUS"_U_2
  S ELIGLIST("A",7)=" 7 - CURRENT MEANS TEST",DATA(SUB,7,9)="CURRENT MEANS TEST"_U_2
+ S ELIGLIST("A",1)=" 1 - PRIMARY ELGIBILITY CODE",ELIGDATA(1,1)="PRIMARY ELGIBILITY CODE"_U_2
+ S ELIGLIST("A",2)=" 2 - PERIOD OF SERVICE",ELIGDATA(2,2)="PERIOD OF SERVICE"_U_2
+ S ELIGLIST("A",3)=" 3 - % SERVICE CONNECTED",ELIGDATA(3,3)="% SERVICE CONNECTED"_U_2
+ S ELIGLIST("A",4)=" 4 - VETERAN",ELIGDATA(4,4)="VETERAN"_U_1
+ S ELIGLIST("A",5)=" 5 - TYPE",ELIGDATA(5,6)="TYPE"_U_2
+ S ELIGLIST("A",6)=" 6 - ELIGIBILITY STATUS",ELIGDATA(6,8)="ELIGIBILITY STATUS"_U_2
+ S ELIGLIST("A",7)=" 7 - CURRENT MEANS TEST",ELIGDATA(7,9)="CURRENT MEANS TEST"_U_2
  S ELIGLIST("A")="Enter your selection(s)"
  S ELIGLIST("?")="^D HELP^PXRMPDRS"
 …
  S LIST=$$SEL^PXRMPDRS(.ELIGLIST,7)
  I $D(DTOUT)!$D(DUOUT) Q
  S DATA(SUB)=LIST
  S DATA(SUB,"LEN")=$L(LIST,",")-1
+ S ELIGDATA=LIST
+ S ELIGDATA("LEN")=$L(LIST,",")-1
+ Q
+ ;
 …
+ Q
+ ;
 INPSEL(DATA,SUB) ;Let the user select the inpatient information they want.
+INPSEL(INPDATA) ;Let the user select the inpatient information they want.
  ;The first subscript of INPDATA is the selection number and the
  ;the second subscript is the subscript where the data is returned
 …
  ;second piece is the piece of VAIN this is displayed.
  N INPLIST,ITEM,LIST
  S INPLIST("A",1)=" 1 - WARD LOCATION",DATA(SUB,1,4)="WARD"_U_2
  S INPLIST("A",2)=" 2 - ROOM-BED",DATA(SUB,2,5)="ROOM-BED"_U_1
  S INPLIST("A",3)=" 3 - ADMISSION DATE/TIME",DATA(SUB,3,7)="ADMISSION DATE/TIME"_U_2
  S INPLIST("A",4)=" 4 - ATTENDING PHYSICIAN",DATA(SUB,4,11)="ATTENDING"_U_2
+ S INPLIST("A",1)=" 1 - WARD LOCATION",INPDATA(1,4)="WARD"_U_2
+ S INPLIST("A",2)=" 2 - ROOM-BED",INPDATA(2,5)="ROOM-BED"_U_1
+ S INPLIST("A",3)=" 3 - ADMISSION DATE/TIME",INPDATA(3,7)="ADMISSION DATE/TIME"_U_2
+ S INPLIST("A",4)=" 4 - ATTENDING PHYSICIAN",INPDATA(4,11)="ATTENDING"_U_2
  S INPLIST("A")="Enter your selection(s)"
  S INPLIST("?")="^D HELP^PXRMPDRS"
 …
  S LIST=$$SEL^PXRMPDRS(.INPLIST,5)
  I $D(DTOUT)!$D(DUOUT) Q
  S DATA(SUB)=LIST
  S DATA(SUB,"LEN")=$L(LIST,",")-1
+ S INPDATA=LIST
+ S INPDATA("LEN")=$L(LIST,",")-1
+ Q
+ ;
 REMSEL(PLIEN,DATA,SUB) ;If the list was generated from a reminder report
+REMSEL(PLIEN,REMDATA) ;If the list was generated from a reminder report
  ;let the user select the reminder data they want.
  I '$P(^PXRMXP(810.5,PLIEN,0),U,9) S DATA(SUB,"LEN")=0 Q
+ I '$P(^PXRMXP(810.5,PLIEN,0),U,9) S REMDATA("LEN")=0 Q
  N IEN,IND,REMLIST,RNAME
  S (IEN,IND)=0
 …
  . I RNAME="" S RNAME=$P(^PXD(811.9,IEN,0),U,1)
  . S IND=IND+1
  . S DATA(SUB,"RNAME",IND)=RNAME
  . S DATA(SUB,"IEN",IND)=IEN
+ . S REMDATA("RNAME",IND)=RNAME
+ . S REMDATA("IEN",IND)=IEN
  . S REMLIST("A",IND)=" "_IND_" - "_RNAME
  S REMLIST("A")="Enter your selection(s)"
 …
  S LIST=$$SEL^PXRMPDRS(.REMLIST,IND)
  I $D(DTOUT)!$D(DUOUT) Q
  S DATA(SUB)=LIST
  S DATA(SUB,"LEN")=$L(LIST,",")-1
+ S REMDATA=LIST
+ S REMDATA("LEN")=$L(LIST,",")-1
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPLST.m

-              r628
+              r636
 PXRMPLST ; SLC/PKR - Build a patient list from a reminder definition. ;01/24/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPLST ; SLC/PKR - Build a patient list from a reminder definition. ;06/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;Input  :  RIEN     - Reminder IEN
 …
  ;          PXRMDATE - Evaluation date
  ;===================================================
 BLDPLST(DEFARR,PLIST,DFNONLY) ;
  N DFN,DOBE,DOBS,ELE,ERROR,ERRSTR,IND,FNUM
+BLDPLST(RIEN,PLIST,DFNONLY,PXRMDATE) ;
+ N DEFARR,DFN,DOBE,DOBS,ELE,ERROR,ERRSTR,IND,FNUM
  N LIST1,LIST2,LNAME,LSP,LSTACK
  N NDR,NOT,OPER,PCLOG,PFSTACK,SEX,TYPE
+ ;
+ D DEF^PXRMLDR(RIEN,.DEFARR)
  ;Get the cohort logic string. This has passed a validation before
  ;it can be selected for building patient lists so we don't need to
 …
  N DFN,DS,IND,SEXOK
  F IND=1:1:NDR D
  . S DS=DOBS(IND)-.000001
+ . S DS=DOBS(IND)-.1
  . F  S DS=$O(^DPT("ADOB",DS)) Q:(DS>DOBE(IND))!(DS="")  D
  .. S DFN=""

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPTD2.m

-              r628
+              r636
 PXRMPTD2 ; SLC/PKR/PJH - Reminder Inquiry print template routines.;03/06/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPTD2 ; SLC/PKR/PJH - Reminder Inquiry print template routines.;10/07/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;================================================
 DATE(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD,FILENUM,FLG) ;Standard DATE
 …
  S DATE=$P($G(FIND0),U,PIECE)
  I DATE'="" D
  .S DATE=$$FMTE^XLFDT(DATE,"5Z"),X=$$RJ^XLFSTR(TITLE,RJC,PAD),X=X_" "_DATE
+ .S DATE=$$FMTE^XLFDT(DATE,"D"),X=$$RJ^XLFSTR(TITLE,RJC,PAD),X=X_" "_DATE
  .D ^DIWP
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPTDF.m

-              r628
+              r636
 PXRMPTDF ; SLC/PKR/PJH - Reminder Inquiry print template routines. ;06/07/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPTDF ; SLC/PKR/PJH - Reminder Inquiry print template routines. ;01/30/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;================================================
 …
  .D SFDISP(FIND0,1,14,"Condition:",RJC,PAD,FILENUM)
  .D SFDISP(FIND0,2,15,"Condition Case Sensitive:",RJC,PAD,FILENUM)
  .D SFDISP(FIND0,3,18,"Use Status/Cond in Search:",RJC,PAD,FILENUM)
+ .D SFDISP(FIND0,3,18,"Use Cond in Finding Search:",RJC,PAD,FILENUM)
  .I $G(^PXD(811.9,D0,20,FINDING,15))'="" D
  ..S X=$$RJ^XLFSTR("Computed Finding Parameter:",RJC,PAD)
 …
  .D SFDISP(TERM3,1,14,"Condition:",RJT,PAD,TERMNUM,1)
  .D SFDISP(TERM3,2,15,"Condition Case Sensitive:",RJT,PAD,TERMNUM)
  .D SFDISP(TERM3,3,18,"Use Status/Cond in Search:",RJT,PAD,TERMNUM)
+ .D SFDISP(TERM3,3,18,"Use Cond in Finding Search:",RJT,PAD,TERMNUM)
  .I $G(^PXRMD(811.5,IEN1,20,TERMS,15))'="" D
  ..S X=$$RJ^XLFSTR("Computed Finding Parameter:",RJT,PAD)
 …
  .S X=$$RJ^XLFSTR(TITLE,RJC,PAD)
  .S X=X_" "_$$EXTERNAL^DILFD(FILENUM,FLDNUM,"",FIELD,"")
+ .I FLDNUM=13 S X=X_" - "_$$SPECIAL(FIND0,FIELD)
+ .D ^DIWP
+ Q
+ ;
+ ;================================================
+SPECIAL(FIND0,FIELD) ;Special output for certain fields.
+ N FINDING,GLOBAL,IEN
+ S FINDING=$P(FIND0,U,1)
+ S IEN=$P(FINDING,";",1)
+ S GLOBAL=$P(FINDING,";",2)
+ I GLOBAL="YTT(601.71," Q $$SCNAME^PXRMMH(IEN,FIELD)
+ Q ""
+ .D ^DIWP
+ Q
+ ;
  ;================================================

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPTTR.m

-              r628
+              r636
 PXRMPTTR ;SLC/PKR - Routines for term print templates ;06/01/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPTTR ;SLC/PKR - Routines for term print templates ;01/30/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;====================================================
 …
  . D SFDISP(FIND0,1,14,"Condition:",RJC,PAD)
  . D SFDISP(FIND0,2,15,"Condition Case Sensitive:",RJC,PAD)
  . D SFDISP(FIND0,3,18,"Use Status/Cond in Search:",RJC,PAD)
+ . D SFDISP(FIND0,3,18,"Use Cond in Finding Search:",RJC,PAD)
  . I $G(^PXRMD(811.5,D0,20,FINDING,15))'="" D
  .. S CFP=$$RJ^XLFSTR("Computed Finding Parameter:",RJC,PAD)
 …
  . S TEXT=$$RJ^XLFSTR(TITLE,RJC,PAD)
  . S TEXT=TEXT_"  "_$$EXTERNAL^DILFD(811.52,FLDNUM,"",FIELD,"")
- . I FLDNUM=13 S TEXT=TEXT_" - "_$$SPECIAL^PXRMPTDF(FIND0,FIELD)
  . W !,TEXT
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMREDF.m

-              r628
+              r636
 PXRMREDF ; SLC/PJH - Edit PXRM reminder findings. ;01/09/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMREDF ; SLC/PJH - Edit PXRM reminder findings. ;02/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ; Called by PXRMREDT which newes and initialized DEF, DEF1, DEF2.
 …
  D ^DIC I Y=-1 S DTOUT=1 Q
  S DIE=DIC K DIC
- S DIE("NO^")="OUTOK"
  S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB=""
  S TYPE=$G(DEF1(GLOB))
 …
  ;Save term IEN
  S STATUS=0
+ I TYPE="RT" S TIEN=$P($P(Y,U,2),";",1)
  I TYPE="CF" S CFIEN=$P($P(Y,U,2),";",1) D
  .I $D(^PXRMD(811.4,CFIEN,1))>0 D
 …
  ...W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))
  .E  W !!,"No description defined for this computed finding"
- I TYPE="MH" D WARN^PXRMMH
- I TYPE="RT" S TIEN=$P($P(Y,U,2),";",1)
  ;Finding record fields
  W !!,"Editing Finding Number: "_$G(DA)
 …
  ;Check if deleted
  I '$D(DA) Q
  I STATUS=1,$D(Y)=0 D STATUS^PXRMSTA1(.DA,"D")
+ I STATUS=1 D STATUS^PXRMSTA1(.DA,"D")
+ ;
  S ETYPE=$P(^PXD(811.9,IEN,20,SDA(1),0),U,1)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMREDT.m

-              r628
+              r636
 PXRMREDT ; SLC/PKR,PJH - Edit PXRM reminder definition. ;10/04/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMREDT ; SLC/PKR,PJH - Edit PXRM reminder definition. ;02/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;=======================================================
 …
  D SETSTART^PXRMCOPY(DIC)
  W !
- S DIC("W")="W $$LUDISP^PXRMREDT(Y)"
  D ^DIC
  I ($D(DTOUT))!($D(DUOUT)) Q
 …
+ ;
  ;-------------------------------------
-LUDISP(IEN) ;Use for DIC("W") to augment look-up display.
- N CLASS,EM,INACTIVE,TEXT
- S INACTIVE=$P(^PXD(811.9,IEN,0),U,6)
- S CLASS=$P(^PXD(811.9,IEN,100),U,1)
- I INACTIVE'="" S INACTIVE="("_$$EXTERNAL^DILFD(811.9,1.6,"",INACTIVE,.EM)_")"
- S CLASS=$$EXTERNAL^DILFD(811.9,100,"",CLASS,.EM)
- S TEXT="  "_CLASS_" "_INACTIVE
- Q TEXT
+ ;
- ;-------------------------------------
 TFIND(DA,LIST) ;Allow edit of term findings for national reminders.
  N DIR,IENLIST,IND,JND,NAME,NAMELIST,SUB,X,Y
+ N DIR,IENLIST,IND,NAME,NAMELIST,SUB,X,Y
  S IND=0,NAME=""
  F  S NAME=$O(LIST("RT",NAME)) Q:NAME=""  D
 …
  I $D(DIROUT)!$D(DIRUT) S LIST="" Q
  I $D(DUOUT)!$D(DTOUT) S LIST="" Q
+ S LIST=Y
  F IND=1:1:$L(Y,",")-1 D
+ . S JND=$P(Y,",",IND)
+ . S NAME=$P(NAMELIST(JND),JND,2)
+ . S NAME=$P(NAMELIST(IND),IND,2)
  . W !!,"Reminder Term:",NAME
  . D TMAP^PXRMREDF(DA,IENLIST(JND))
+ Q
+ ;
+ . D TMAP^PXRMREDF(DA,IENLIST(IND))
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMRPCC.m

r628	r636
1		PXRMRPCC ;SLC/PJH - PXRM REMINDER DIALOG ;~~11/26/2007~~
2		;;2.0;CLINICAL REMINDERS;6;Feb 04, 2005;Build 123
	1	PXRMRPCC ;SLC/PJH - PXRM REMINDER DIALOG ;04/12/2002
	2	;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3	3	;
4	4	ACTIVE(ORY,ORREM) ;Check if active dialog exist for reminders
…	…
39	39	;
40	40	;Load dialog lines into local array
41		~~S ORY(0)=0_U_+$P($G(^PXRMD(801.41,DIEN,0)),U,17)~~
42	41	D LOAD^PXRMDLL(DIEN,$G(DFN))
43	42	Q
…	…
77	76	; Input mental health instrument NAME
78	77	;
79		K ^TMP($J,"YSQU")
80		N ARRAY,CNT,CNT1,FNODE,FSUB,IC,NODE,OCNT,SUB,YS
81		;DBIA #5056
82		S YS("CODE")=OTEST D SHOWALL^YTQPXRM5(.ARRAY,.YS)
83		S OCNT=0,CNT=0
	78	N YS,ARRAY S YS("CODE")=OTEST D SHOWALL^YTAPI3(.ARRAY,.YS) ; DBIA #2895
	79	;
	80	N FNODE,FSUB,IC,NODE,OCNT,SUB
84	81	S SUB="ARRAY",OCNT=0
85	82	F S SUB=$Q(@SUB) Q:SUB="" D
…	…
96	93	; Input MH result IEN and mental health instrument response
97	94	;
98		D ~~START^PXRMDLR(.ORY,RESULT,.ORES)~~
	95	D ^PXRMDLR
99	96	;
100	97	Q
…	…
103	100	;
104	101	; Input mental health instrument response
105		N ANS,ARRAY,X
106		S ANS=$G(YS("R1")) K YS("R1")
107		S YS("ADATE")=YS("ADATE")_"."_$P($$NOW^XLFDT,".",2)
108		F X=1:1:$L(ANS) I $E(ANS,X)'="X" S YS(X)=X_U_$E(ANS,X)
109		;DBIA #4463
110		D SAVECR^YTQPXRM4(.ARRAY,.YS)
	102	N ARRAY
	103	D SAVEIT^YTAPI1(.ARRAY,.YS) ; DBIA #2893
	104	I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2)
	105	I ARRAY(1)="[DATA]" S ORY(1)=ARRAY(1)_ARRAY(2)
111	106	Q
112	107	;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMRUL1.m

-              r628
+              r636
 PXRMRUL1 ; SLC/AGP,PKR - Patient list routines. ; 03/29/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMRUL1 ; SLC/AGP,PKR - Patient list routines. ; 08/11/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;
-ASK(PLIEN,OPT) ;Verify patient list name
- N X,Y,TEXT
- K DIROUT,DIRUT,DTOUT,DUOUT
- S DIR(0)="YA0"
- S DIR("A")=OPT_" patient list "_$P($G(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
- S DIR("B")="N"
- S DIR("?")="Enter Y or N. For detailed help type ??"
- W !
- D ^DIR K DIR
- I $D(DIROUT) S DTOUT=1
- I $D(DTOUT)!($D(DUOUT)) Q
- I $E(Y(0))="N" S DUOUT=1 Q
+ Q
+ ;
-COPY(IENO) ;Copy patient list
- ;Check if OK to copy
- D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)
- N FDA,IENN,IND,MSG,NNAME,ODATA,OEPIEN,ONAME,ORULE,PATCREAT,TEXT,X,Y
- ;Select list to copy to
- S TEXT="Select PATIENT LIST name to copy to: "
- D PLIST^PXRMLCR(.IENN,TEXT,IENO) Q:$D(DUOUT)!$D(DTOUT)  Q:'IENN
- S NNAME=$P($G(^PXRMXP(810.5,IENN,0)),U)
+ ;
- ;Get original Patient List record
- S ODATA=$G(^PXRMXP(810.5,IENO,0))
- S ONAME=$P(ODATA,U),OEPIEN=$P(ODATA,U,5),ORULE=$P(ODATA,U,6)
+ ;
- M ^PXRMXP(810.5,IENN)=^PXRMXP(810.5,IENO)
- D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2)
- ;Update header info
- S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
- S IND=IENN_","
- S FDA(810.5,IND,.01)=NNAME
- S FDA(810.5,IND,.04)=$$NOW^XLFDT
- S FDA(810.5,IND,.05)=OEPIEN
- S FDA(810.5,IND,.06)=ORULE
- S FDA(810.5,IND,.07)=$G(DUZ)
- S FDA(810.5,IND,.08)=TYPE
- D UPDATE^DIE("","FDA","","MSG")
- ;Error
- I $D(MSG) D ERR
+ ;
- W !!,"Completed copy of '"_ONAME_"'"
- W !,"into '"_NNAME_"'",! H 2
- K ^TMP($J,"PXRMRULE")
+ Q
+ ;
-CRLST(NAME,CLASS) ;Create new patient list
- N IEN
- ;Check if name exists
- S IEN=$O(^PXRMXP(810.5,"B",NAME,"")) I IEN Q IEN
- ;Otherwise create national entry
- N FDA,FDAIEN,MSG
- S FDA(810.5,"+1,",.01)=NAME
- S FDA(810.5,"+1,",100)=CLASS
- S FDA(810.5,"+1,",.07)=$G(DUZ)
- ;Make stub public
- S FDA(810.5,"+1,",.08)="PUB"
- D UPDATE^DIE("","FDA","FDAIEN","MSG")
- ;Error
- I $D(MSG) Q 0
- ;Otherwise list ien
- Q FDAIEN(1)
+ ;
-COUNT(NODE) ;Count the number of entries.
- N DFN,NUM
- S (DFN,NUM)=0
- F  S DFN=$O(^TMP($J,NODE,DFN)) Q:DFN=""  S NUM=NUM+1
- Q NUM
+ ;
-DELETE(LIST) ;Delete Patient list
- I '$$VEDIT^PXRMUTIL("^PXRMXP(810.5,",LIST) D  Q
- .W !!,?5,"VA- and national class patient lists may not be deleted" H 2
- .S DUOUT=1
- ;Check if this is the right list
- D ASK(LIST,"Delete") Q:$D(DUOUT)!$D(DTOUT)
+ ;
- N DA,DIK,DUOUT
- ;Lock patient list
- D LOCK Q:$D(DUOUT)
- ;Kill List
- S DA=LIST,DIK="^PXRMXP(810.5,"
- D ^DIK
- ;Unlock patient list
- D UNLOCK
+ Q
+ ;
 DATECHK(DATE) ;
  I DATE=0 Q 1
  S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
  Q $$VDT^PXRMINTR(DATE)
+ ;
-DATES(LBBDT,LBEDT,RBDT,REDT,FARR) ;Set the dates in the finding array to
- ;FileMan dates.
- N FI,PXRMDATE,TBDT,TEDT
- S FI=0
- F  S FI=+$O(FARR(20,FI)) Q:FI=0  D
- . S TBDT=$P(FARR(20,FI,0),U,8),TEDT=$P(FARR(20,FI,0),U,11)
- . I TBDT="",TEDT="" D
- .. S $P(FARR(20,FI,0),U,8)=RBDT,$P(FARR(20,FI,0),U,11)=REDT
- . E  D
- .. S PXRMDATE=$S(TBDT["BDT":LBBDT,1:LBEDT)
- .. S TBDT=$S(TBDT="":0,TBDT=0:0,TBDT="BDT":LBBDT,1:$$CTFMD^PXRMDATE(TBDT))
- .. S PXRMDATE=$S(TEDT["BDT":LBBDT,1:LBEDT)
- .. S TEDT=$S(TEDT="":"T",TEDT=0:"T",TEDT="BDT":LBBDT,1:TEDT)
- .. S TEDT=$$CTFMD^PXRMDATE(TEDT)
- .. S $P(FARR(20,FI,0),U,8)=TBDT,$P(FARR(20,FI,0),U,11)=TEDT
+ Q
+ ;
-ERR ;Error Handler
- N ERROR,IC,REF
- S ERROR(1)="Unable to build patient list : "
- S ERROR(2)=NAME
- S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
- ; Move MSG into Error
- S REF="MSG"
- F IC=4:1 S REF=$Q(@REF) Q:REF=""  S ERROR(IC)=REF_"="_@REF
- ;Screen message
- D EN^DDIOL(.ERROR)
+ Q
+ ;
 INSERT(FROUT,DFN,TNAME,TFIEV,RSTOP) ;Save patient data.
 …
  Q INST
+ ;
-LOCK L +^PXRMXP(810.5,LIST):0
- E  W !!?5,"Another user is using this patient list" S DUOUT=1
+ Q
+ ;
 LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical
  ;operator LOGOP to generate a new list and return it in LIST1
 …
+ Q
+ ;
+REM(FRACT,RIEN,LBBDT,LBEDT,RSTART,RSTOP,PNODE) ;Process reminder finding rule
+ N DEFFARR,PXRMDATE
+ D DEF^PXRMLDR(RIEN,.DEFARR)
+ D DATES(LBBDT,LBEDT,RSTART,RSTOP,.DEFARR)
+ S PXRMDATE=RSTOP
+ D BLDPLST^PXRMPLST(.DEFARR,PNODE,1)
+REM(FRACT,RIEN,RSTART,RSTOP,PNODE) ;Process reminder finding rule
+ D BLDPLST^PXRMPLST(RIEN,PNODE,1,RSTOP)
  ;Remove, Select or Add Findings operations
  I FRACT="A" D LOGOP(FROUT,PNODE,"!") Q
 …
+ Q
+ ;
+TERM(FRACT,FRTIEN,LBBDT,LBEDT,RSTART,RSTOP,PNODE,INST) ;Process TERM finding
+ ;rules
+ N FINDPA,FINDING,FNAME,PLIST,PXRMDATE,PXRMDEBG
+ N TERMARR,TFIEV,TNAME
+TERM(FRACT,FRTIEN,RSTART,RSTOP,PNODE,INST) ;Process TERM finding rule
+ N FINDPA,FINDING,FNAME,PLIST,PXRMDATE,PXRMDEBG,TERMARR,TFIEV,TNAME
  ;Get term definition array
  D TERM^PXRMLDR(FRTIEN,.TERMARR)
  S TNAME=$P(TERMARR(0),U,1)
  S INST=$S(FRACT'="F":0,TNAME="VA-PCMM INSTITUTION":1,TNAME="VA-IHD STATION CODE":1,1:0)
+ ;Set begin and end dates in the term.
+ D DATES(LBBDT,LBEDT,RSTART,RSTOP,.TERMARR)
+ ;Set start and end dates
  S $P(FINDPA(0),U,8)=RSTART,$P(FINDPA(0),U,11)=RSTOP,PXRMDATE=RSTOP
+ ;
 …
  I FRACT="A" D  Q
  .;Process term for date range
  .D EVALPL^PXRMTERL(.FINDPA,.TERMARR,PNODE)
+ .D EVALPL^PXRMTERM(.FINDPA,.TERMARR,PNODE)
  .;Merge lists if operation is add
  .M ^TMP($J,FROUT)=^TMP($J,PNODE,1)
 …
+ Q
+ ;
-UNLOCK L -^PXRMXP(810.5,LIST) Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m

-              r628
+              r636
 PXRMRULE ; SLC/PJH - Build Patient list from Rule Set ;03/27/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMRULE ; SLC/PJH - Build Patient list from Rule Set ;08/11/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ; Called from PXRM PATIENT LIST CREATE protocol
+ ;
+ASK(PLIEN,OPT) ;Verify patient list name
+ N X,Y,TEXT
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="YA0"
+ S DIR("A")=OPT_" patient list "_$P($G(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
+ S DIR("B")="N"
+ S DIR("?")="Enter Y or N. For detailed help type ??"
+ W !
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ I $E(Y(0))="N" S DUOUT=1 Q
+ Q
+ ;
 CLEAR(RULE,NODE) ;Clear workfile entries
 …
+ Q
+ ;
+COPY(IENO) ;Copy patient list
+ ;Check if OK to copy
+ D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)
+ N FDA,IENN,IND,MSG,NNAME,ODATA,OEPIEN,ONAME,ORULE,PATCREAT,TEXT,X,Y
+ ;Select list to copy to
+ S TEXT="Select PATIENT LIST name to copy to: "
+ D PLIST^PXRMLCR(.IENN,TEXT,IENO) Q:$D(DUOUT)!$D(DTOUT)  Q:'IENN
+ S NNAME=$P($G(^PXRMXP(810.5,IENN,0)),U)
+ ;
+ ;Get original Patient List record
+ S ODATA=$G(^PXRMXP(810.5,IENO,0))
+ S ONAME=$P(ODATA,U),OEPIEN=$P(ODATA,U,5),ORULE=$P(ODATA,U,6)
+ ;
+ M ^PXRMXP(810.5,IENN)=^PXRMXP(810.5,IENO)
+ D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2)
+ ;Update header info
+ S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
+ S IND=IENN_","
+ S FDA(810.5,IND,.01)=NNAME
+ S FDA(810.5,IND,.04)=$$NOW^XLFDT
+ S FDA(810.5,IND,.05)=OEPIEN
+ S FDA(810.5,IND,.06)=ORULE
+ S FDA(810.5,IND,.07)=$G(DUZ)
+ S FDA(810.5,IND,.08)=TYPE
+ D UPDATE^DIE("","FDA","","MSG")
+ ;Error
+ I $D(MSG) D ERR
+ ;
+ W !!,"Completed copy of '"_ONAME_"'"
+ W !,"into '"_NNAME_"'",! H 2
+ K ^TMP($J,"PXRMRULE")
+ Q
+ ;
+CRLST(NAME,CLASS) ;Create new patient list
+ N IEN
+ ;Check if name exists
+ S IEN=$O(^PXRMXP(810.5,"B",NAME,"")) I IEN Q IEN
+ ;Otherwise create national entry
+ N FDA,FDAIEN,MSG
+ S FDA(810.5,"+1,",.01)=NAME
+ S FDA(810.5,"+1,",100)=CLASS
+ D UPDATE^DIE("","FDA","FDAIEN","MSG")
+ ;Error
+ I $D(MSG) Q 0
+ ;Otherwise list ien
+ Q FDAIEN(1)
+ ;
+DELETE(LIST) ;Delete Patient list
+ I '$$VEDIT^PXRMUTIL("^PXRMXP(810.5,",LIST) D  Q
+ .W !!,?5,"VA- and national class patient lists may not be deleted" H 2
+ .S DUOUT=1
+ ;Check if this is the right list
+ D ASK(LIST,"Delete") Q:$D(DUOUT)!$D(DTOUT)
+ ;
+ N DA,DIK,DUOUT
+ ;Lock patient list
+ D LOCK Q:$D(DUOUT)
+ ;Kill List
+ S DA=LIST,DIK="^PXRMXP(810.5,"
+ D ^DIK
+ ;Unlock patient list
+ D UNLOCK
+ Q
+ ;
+ERR ;Error Handler
+ N ERROR,IC,REF
+ S ERROR(1)="Unable to build patient list : "
+ S ERROR(2)=NAME
+ S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
+ ; Move MSG into Error
+ S REF="MSG"
+ F IC=4:1 S REF=$Q(@REF) Q:REF=""  S ERROR(IC)=REF_"="_@REF
+ ;Screen message
+ D EN^DDIOL(.ERROR)
+ Q
+ ;
 INTR ;Input transform for #810.4 fields
+ Q
 …
+ Q
+ ;
+PATS(FRACT,FROUT,PNODE,LIST) ;Process Patient List finding rule
+LOCK L +^PXRMXP(810.5,LIST):0
+ E  W !!?5,"Another user is using this patient list" S DUOUT=1
+ Q
+ ;
+PATS(LIST) ;Process Patient List finding rule
+ ;
  N LIEN,LUVALUE
 …
  I FRACT="A" D LOAD(FROUT,LIEN) Q
+ ;
+ ;Remove or Select operations
+ ;Load List
+ D LOAD(PNODE,LIEN)
+ ;Check each patient
+ S DFN=0
+ F  S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN  D
+ .;Delete any ^TMP patient in PLIST if action is remove
+ .I FRACT="R",$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN) Q
+ .;Delete any ^TMP patient not in PLIST if action is select
+ .I FRACT="S",'$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN)
+ Q
+ ;
+START(RULESET,LIST,NODE,LBBDT,LBEDT,PAR,YEAR,PERIOD,INDP,INTP,EXTITR) ;
+ ;Remove, Select or Add Findings operations
+ I FRACT'="A" D  Q
+ .;Load List
+ .D LOAD(PNODE,LIEN)
+ .;Check each patient
+ .S DFN=0
+ .F  S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN  D
+ ..;Delete any ^TMP patient in PLIST if action is remove
+ ..I FRACT="R",$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN) Q
+ ..;Delete any ^TMP patient not in PLIST if action is select
+ ..I FRACT="S",'$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN)
+ Q
+ ;
+START(RULESET,LIST,NODE,LBBDT,LBEDT,PAR,YEAR,PERIOD,INDP,INTP) ;
  ;Process rule set
  ;Clear ^TMP
 …
+ ;
  N CLASS,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
  N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE,PXRMDDOC
+ N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE
  N RBDT,REDT,RRIEN,RSDATA,RSDATES,SEQ,SUB
  ;Get class from extract parameter
 …
  ;Otherwise default to local
  I $G(CLASS)="" S CLASS="L"
- ;PXRMDDOC=1 save list rule evaluation dates in ^TMP("PXRMDDOC",$J)
- S PXRMDDOC=1
- K ^TMP("PXRMDDOC",$J)
  ;Get each finding rule in sequence
  S SEQ="",INC=0,INST=0
+ S SEQ="",INC=0
  F  S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ  D
  .;Save first sequence as default
 …
  .;Get Extract Patient List name for patient list rule
  .I FRTYP=5 S FRLST=$P($G(^PXRM(810.4,FRIEN,1)),U) D  Q:FRLST=""
- ..I +EXTITR>0 S FRLST=FRLST_"/"_EXTITR
  ..S FROLST=$P(FRDATA,U,8)
  ..I +FROLST>0 S FRLST=$P($G(^PXRMXP(810.5,FROLST,0)),U)
 …
  .K ^TMP($J,PNODE)
  .;Term finding rules
  .I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,LBBDT,LBEDT,RBDT,REDT,PNODE,.INST)
+ .I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,RBDT,REDT,PNODE,.INST)
  .;Reminder Definition List Rule
  .I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,LBBDT,LBEDT,RBDT,REDT,PNODE)
+ .I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,RBDT,REDT,PNODE)
  .;Patient list finding rules
  .I FRTYP=5 D PATS(FRACT,FROUT,PNODE,FRLST)
+ .I FRTYP=5 D PATS(FRLST)
  .;Clear results file
  .K ^TMP($J,PNODE)
 …
  ..N FRPIEN
  ..;Get patient list IEN or create new patient list
  ..S FRPIEN=$$CRLST^PXRMRUL1(FRPERM,CLASS) Q:'FRPIEN
+ ..S FRPIEN=$$CRLST(FRPERM,CLASS) Q:'FRPIEN
  ..;Update patient list
  ..D UPDLST(FROUT,FRPIEN,PAR,RULESET,INST,INDP,INTP)
+ ..D UPDLST(FROUT,FRPIEN,PAR,RULESET,INST)
+ ;
  ;Save final results to patient list
  I LIST'="",FROUT'="" D
  . D RMPAT^PXRMEUT(FROUT,INDP,INTP)
+ . D UPDLST(FROUT,LIST,PAR,RULESET,INST,INDP,INTP)
+ .;PXRMDDOC=2 compare saved dates with those generated in
+ .;DOCUMENT^PXRMEUT.
+ . S PXRMDDOC=2
+ . D UPDLST(FROUT,LIST,PAR,RULESET,INST)
  . D DOCUMENT^PXRMEUT(LIST,RULESET,INDP,INTP,LBBDT,LBEDT)
+ K ^TMP("PXRMDDOC",$J)
+ Q
+ ;
+UPDLST(NODE,LIST,EPIEN,RULE,INST,INDP,INTP) ;Update patient list
+ N CNT,DA,DATA,DCNT,DECEASED,DFN,DNAME,DNAMEL,DOD,DUE,DUOUT,FDA
+ N INSTNAM,INSTNUM,LAST,MSG,NAME,ONODE
+ N RCNT,RIEN,RNAMEL,RNCNT,SUB,TEMP,TEST,TYPE,VALUE
+ Q
+ ;
+UPDLST(NODE,LIST,EPIEN,RULE,INST) ;Update patient list
+ N CNT,DA,DATA,DCNT,DFN,DNAME,DNAMEL,DUE,DUOUT,FDA,INST,INSTNAM,INSTNUM
+ N LAST,MSG,NAME,ONODE,RCNT,RIEN,RNAMEL,RNCNT,SUB,TEMP,TYPE,VALUE
  ;Lock patient list
+ D LOCK^PXRMRUL1 Q:$D(DUOUT)
+ S TEMP=^PXRMXP(810.5,LIST,0)
+ S NAME=$P(TEMP,U,1)
+ S $P(^PXRMXP(810.5,LIST,0),U,11)=INDP
+ S $P(^PXRMXP(810.5,LIST,0),U,12)=INTP
+ D LOCK Q:$D(DUOUT)
+ ;
  ;Clear existing list.
  K ^PXRMXP(810.5,LIST,30),^PXRMXP(810.5,LIST,35),^PXRMXP(810.5,LIST,45),^PXRMXP(810.5,LIST,200)
+ S NAME=$P($G(^PXRMXP(810.5,LIST,0)),U)
+ ;
  ;Merge ^TMP into Patient List
+ S (DECEASED,TESTP)=""
+ S (CNT,DFN)=0
+ S (CNT,DFN,INST)=0
  F  S DFN=$O(^TMP($J,NODE,DFN)) Q:'DFN  D
  .S ONODE=$G(^TMP($J,NODE,DFN,"INST"))
  .S INSTNUM=$P(ONODE,U,1),INSTNAM=$P(ONODE,U,2)
+ .S TEMP=DFN_U_INSTNUM_U_INSTNAM
+ .I INDP D
+ ..;DBIA #10035
+ ..S DOD=+$P($G(^DPT(DFN,.35)),U,1)
+ ..S DECEASED=$S(DOD=0:0,1:1)
+ .;DBIA #3744
+ .I INTP S TESTP=$$TESTPAT^VADPT(DFN)
+ .S CNT=CNT+1,^PXRMXP(810.5,LIST,30,CNT,0)=DFN_U_INSTNUM_U_INSTNAM_U_DECEASED_U_TESTP
+ .S CNT=CNT+1,^PXRMXP(810.5,LIST,30,CNT,0)=DFN_U_INSTNUM_U_INSTNAM
  .S ^PXRMXP(810.5,LIST,30,"B",DFN,CNT)=""
  .;
 …
  D UPDATE^DIE("","FDA","","MSG")
  ;Error
  I $D(MSG) D ERR^PXRMRUL1
+ I $D(MSG) D ERR
  ;Unlock patient list
+ D UNLOCK^PXRMRUL1
+ Q
+ ;
+ D UNLOCK
+ Q
+ ;
+UNLOCK L -^PXRMXP(810.5,LIST) Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMSTA1.m

-              r628
+              r636
 PXRMSTA1 ; SLC/AGP - Routines for building status list. ;09/06/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMSTA1 ; SLC/AGP - Routines for building status list. ;06/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;This routine and PXRMSTA2 will allow users to select the
 …
+ ;
 ADDDEL(ANS,GBL,FILE,TYPE,NODE,WILD,DA,UPDATE,DELALL) ;
  I $G(ANS)="" S ANS=$$PROMPT("S^A:ADD STATUS;D:DELETE A STATUS;S:SAVE AND QUIT;Q:QUIT WITHOUT SAVING CHANGES")
+ I $G(ANS)="" S ANS=$$PROMPT("S^A:ADD STATUS;D:DELETE A STATUS;S:SAVE AND QUIT;Q:QUIT WITHOUT SAVING CHANGES","S")
  I "ADDASQ"'[ANS Q
  I ANS="A",WILD=1 D
 …
  I TYPE[";" S TYPE=$P($G(TYPE),";",2)
  I TYPE="PXD(811.2," D  G ADDEX
  .I $G(TAXTYPE)="R"!($G(TAXTYPE)="B") D DATA^PXRMSTA2(FILE,.DA,"RAMIS(71,","",.STATUS)
+ .I $G(TAXTYPE)="R" D DATA^PXRMSTA2(FILE,.DA,"RAMIS(71,","",.STATUS)
  .;I $G(TAXTYPE)="P" D DATA^PXRMSTA2(FILE,.DA,"PROB","",.STATUS)
  .;I $G(TAXTYPE)="B" D DATA^PXRMSTA2(FILE,.DA,"TAX","",.STATUS)
+ .I $G(TAXTYPE)="B" D DATA^PXRMSTA2(FILE,.DA,"TAX","",.STATUS)
  ; handle drug finding items
  I TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D  G ADDEX
 …
  I TYPE[";" S TYPE=$P($G(TYPE),";",2)
  I TYPE="PXD(811.2," D
  .I $G(TAXTYPE)="R"!($G(TAXTYPE)="B") S FILE=70
  .;I $G(TAXTYPE)="P" S FILE=9000011
+ .I $G(TAXTYPE)="R" S FILE=70
+ .I $G(TAXTYPE)="P" S FILE=9000011
  I FILE="",TYPE="ORD(101.43," S FILE=100
  I FILE="",TYPE="RAMIS(71," S FILE=70
 …
+ Q
+ ;
 PROMPT(STR) ;
+PROMPT(STR,DEFAULT) ;
  N DIR,HTEXT
  S HTEXT(1)="Select 'A' to add a status to the current status list.\\Select 'D' to"
  S HTEXT(2)="delete a status from the list.\\Select 'S' to save your changes and quit. "
  S HTEXT(3)="\\Select 'Q' to quit without saving your changes."
+ S HTEXT(1)="Select 'A' to add a status to the current status list. Select 'D' to "
+ S HTEXT(2)="delete a status from the list. Select 'S' to save your changes and quit. "
+ S HTEXT(3)="Select 'Q' to quit without saving your changes."
  S DIR(0)=STR
  S DIR("B")="S"

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMSTA2.m

-              r628
+              r636
 PXRMSTA2 ; SLC/AGP - Routines for building status list. ;03/27/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMSTA2 ; SLC/AGP - Routines for building status list. ;9/26/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
 DATA(FILE,DA,TYPE,RXTYPE,STATUS) ;
 …
  I TYPE="DRUG" D
  .I $D(RXTYPE("I"))>0 D
+ . . D STATUS^PSS55MIS(55.06,28,"SARRAY")
+ . . ;D FIELD^DID(55.06,28,"","POINTER","SARRAY")
+ . . D FIELD^DID(55.06,28,"","POINTER","SARRAY")
  . . D ARRAYFOR(.SARRAY,.ARRAY,"I") K CODE
+ . . D STATUS^PSS55MIS(55.01,100,"SARRAY")
+ . . ;D FIELD^DID(55.01,100,"","POINTER","SARRAY")
+ . . D FIELD^DID(55.01,100,"","POINTER","SARRAY")
  . . D ARRAYFOR(.SARRAY,.ARRAY1,"I") K CODE
  . . D COMPARE(.ARRAY,.ARRAY1,"I",.OUTPUT)
  . I $D(RXTYPE("O"))>0 D
  . . K ARRAY,ARRAY1,CODE
+ . . D STATUS^PSODI(52,100,"SARRAY")
+ . . ;D FIELD^DID(52,100,"","POINTER","SARRAY")
+ . . D FIELD^DID(52,100,"","POINTER","SARRAY")
  . . D ARRAYFOR(.SARRAY,.ARRAY,"O") K CODE
  . . I $D(OUTPUT)>0 K ARRAY1 M ARRAY1=OUTPUT K OUTPUT D COMPARE(.ARRAY,.ARRAY1,"",.OUTPUT)
 …
  . I $D(RXTYPE("N"))>0 D
  . . K ARRAY,ARRAY1,CODE
+ . . D STATUS^PSS55MIS(55.05,5,"SARRAY")
+ . . ;D FIELD^DID(55.05,5,"","POINTER","SARRAY")
+ . . D FIELD^DID(55.05,5,"","POINTER","SARRAY")
  . . S SARRAY("POINTER")=SARRAY("POINTER")_"0:ACTIVE;"
  . . D ARRAYFOR(.SARRAY,.ARRAY,"N") K CODE
 …
+ ;
 ARRAYFOR(ARRAY,OUTPUT,DEF) ;
  ;this sub routine is use to format the array data into a standard
+ ;this sub routine is use to format that array data into a standard
  ;format
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMSXRM.m

-              r628
+              r636
 PXRMSXRM ; SLC/PKR - Main driver for building indexes. ;11/23/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMSXRM ; SLC/PKR - Main driver for building indexes. ;12/20/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;==========================================
 …
  S ROUTINE(120.5)="VITALS^GMVPXRM"  ;DBIA #3647
  S ROUTINE(601.2)="INDEX^YTPXRM" ;DBIA #4523
- S ROUTINE(601.84)="INDEX^YTQPXRM" ;DBIA #5055
  S ROUTINE(9000011)="INDEX^GMPLPXRM" ;DBIA #4516
  S ROUTINE(9000010.07)="VPOV^PXPXRMI2" ;DBIA #4520
 …
  ;==========================================
 SEL(LIST,GBL) ;Select global list
+ N ALIST,DIR,DIROUT,DIRUT,DTOUT,DUOUT,INUM,X,Y
+ S INUM=1,ALIST(INUM)="  "_INUM_" - LABORATORY TEST (CH, Anatomic Path, Micro)",GBL(INUM)=63
+ S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - MENTAL HEALTH",GBL(INUM)=601.2
+ S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - MENTAL HEALTH (MHA3)",GBL(INUM)=601.84
+ S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - ORDER",GBL(INUM)=100
+ S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - PTF",GBL(INUM)=45
+ S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - PHARMACY PATIENT",GBL(INUM)=55
+ S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - PRESCRIPTION",GBL(INUM)=52
+ S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - PROBLEM LIST",GBL(INUM)=9000011
+ S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - RADIOLOGY",GBL(INUM)=70
+ S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V CPT",GBL(INUM)=9000010.18
+ S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V EXAM",GBL(INUM)=9000010.13
+ S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V HEALTH FACTORS",GBL(INUM)=9000010.23
+ S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V IMMUNIZATION",GBL(INUM)=9000010.11
+ S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V PATIENT ED",GBL(INUM)=9000010.16
+ S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V POV",GBL(INUM)=9000010.07
+ S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V SKIN TEST",GBL(INUM)=9000010.12
+ S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - VITAL MEASUREMENT",GBL(INUM)=120.5
+ N ALIST,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+ S ALIST(1)="  1 - LABORATORY TEST (CH, Anatomic Path, Micro)",GBL(1)=63
+ S ALIST(2)="  2 - MENTAL HEALTH",GBL(2)=601.2
+ S ALIST(3)="  3 - ORDER",GBL(3)=100
+ S ALIST(4)="  4 - PTF",GBL(4)=45
+ S ALIST(5)="  5 - PHARMACY PATIENT",GBL(5)=55
+ S ALIST(6)="  6 - PRESCRIPTION",GBL(6)=52
+ S ALIST(7)="  7 - PROBLEM LIST",GBL(7)=9000011
+ S ALIST(8)="  8 - RADIOLOGY",GBL(8)=70
+ S ALIST(9)="  9 - V CPT",GBL(9)=9000010.18
+ S ALIST(10)=" 10 - V EXAM",GBL(10)=9000010.13
+ S ALIST(11)=" 11 - V HEALTH FACTORS",GBL(11)=9000010.23
+ S ALIST(12)=" 12 - V IMMUNIZATION",GBL(12)=9000010.11
+ S ALIST(13)=" 13 - V PATIENT ED",GBL(13)=9000010.16
+ S ALIST(14)=" 14 - V POV",GBL(14)=9000010.07
+ S ALIST(15)=" 15 - V SKIN TEST",GBL(15)=9000010.12
+ S ALIST(16)=" 16 - VITAL MEASUREMENT",GBL(16)=120.5
  M DIR("A")=ALIST
  S DIR("A")="Enter your list"
  S DIR(0)="LO^1:"_INUM
+ S DIR(0)="LO^1:16"
  D ^DIR
  I $D(DIROUT)!$D(DIRUT) S LIST="" Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMTAX.m

-              r628
+              r636
 PXRMTAX ; SLC/PKR - Handle taxonomy finding. ;10/11/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMTAX ; SLC/PKR - Handle taxonomy finding. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;==================================================
 …
  S SDIR=$S(NOCC<0:+1,1:-1)
  S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
  S NGET=$S(UCIFS:50,1:NOCC)
+ S NGET=$S(UCIFS:"*",1:NOCC)
+ ;
  I (NICD0>0),INS D FPDAT^PXRMDGPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,"ICD0",.TLIST)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMTERM.m

-              r628
+              r636
 PXRMTERM ; SLC/PKR - Handle reminder terms. ;04/23/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMTERM ; SLC/PKR - Handle reminder terms. ;06/29/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;=============================================
 …
  ... I 'FIEVAL(FINDING) Q
  ... S JND="@"
+ ... F  S JND=$O(TFIEVAL(TFI,JND)) Q:JND=""  M FIEVAL(FINDING,JND)=TFIEVAL(TFI,JND)
+ ... F  S JND=$O(TFIEVAL(TFI,JND)) Q:JND=""  D
+ .... M FIEVAL(FINDING,JND)=TFIEVAL(TFI,JND)
  .. I 'FIEVAL(FINDING) Q
  .. S IND=0
 …
+ ;
  ;=============================================
+EVALPL(FINDPA,TERMARR,PLIST) ;Build a list of patients based on a
+ ;term. The list is returned in:
+ ;^TMP($J,PLIST,T/F,DFN,ITEM,NFOUND,FILENUM)=DAS_U_DATE_U_VALUE
+ ;for findings with a start and stop date the list is
+ ;^TMP($J,PLIST,T/F,DFN,ITEM,NFOUND,FILENUM)=DAS_U_START_U_STOP_U_VALUE
+ N ENODE
+ K ^TMP($J,PLIST)
+ S ENODE=""
+ F  S ENODE=$O(TERMARR("E",ENODE)) Q:ENODE=""  D
+ . I ENODE="AUTTEDT(" D EVALPL^PXRMEDU(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="AUTTEXAM(" D EVALPL^PXRMEXAM(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="AUTTHF(" D EVALPL^PXRMHF(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="AUTTIMM(" D EVALPL^PXRMIMM(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="AUTTSK(" D EVALPL^PXRMSKIN(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="GMRD(120.51," D EVALPL^PXRMVITL(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="LAB(60," D EVALPL^PXRMLAB(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="ORD(101.43," D EVALPL^PXRMORDR(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PXRMD(810.9," D EVALPL^PXRMLOCL(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PXD(811.2," D EVALPL^PXRMTAX(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PXRMD(811.4," D EVALPL^PXRMCF(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PS(50.605," D EVALPL^PXRMDRCL(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PSDRUG(" D EVALPL^PXRMDRUG(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PSNDF(50.6," D EVALPL^PXRMDGEN(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="RAMIS(71," D EVALPL^PXRMRAD(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="YTT(601," D EVALPL^PXRMMH(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ Q
+ ;
+ ;=============================================
 EVALTERM(DFN,FINDPA,TERMARR,TFIEVAL) ;Evaluate all the findings in
  ;a term. Use the "E" cross-reference just like the finding evaluation.
 …
  . I ENODE="PSNDF(50.6," D EVALTERM^PXRMDGEN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
  . I ENODE="RAMIS(71," D EVALTERM^PXRMRAD(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
  . I ENODE="YTT(601.71," D EVALTERM^PXRMMH(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="YTT(601," D EVALTERM^PXRMMH(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ Q
+ ;
 …
  ;=============================================
 OPT(INDENT,IFIEVAL,NLINES,TEXT,TYPE) ;General output.
+ N DG,DGL,DGN,IEN,IND,JND,KND,INDENTT,FILENUM,TEMP,TIFIEVAL
+ N DG,DGL,DGN,DRUG,IEN,IND,JND,KND,INDENTT,FILENUM,TEMP,TIFIEVAL
+ ;If there is a drug make it available for display.
+ S DRUG=$S($D(IFIEVAL("DISPENSE DRUG")):IFIEVAL("DISPENSE DRUG"),1:"")
+ ;DBIA #10043
+ I DRUG'="" S DRUG=$P(^PSDRUG(DRUG,0),U,1)
  ;Build the display grouping.
  S FILENUM=IFIEVAL(1,"FILE NUMBER")
 …
  .. I KND=1 M TIFIEVAL=IFIEVAL(JND)
  .. M TIFIEVAL(KND)=IFIEVAL(JND)
+ .. I DRUG'="" S TIFIEVAL("DISPENSE DRUG")=DRUG
  . I TYPE="CM" D FOUT^PXRMOUTC(INDENTT,.TIFIEVAL,.NLINES,.TEXT)
  . I TYPE="MHV" D FOUT^PXRMOUTM(INDENTT,.TIFIEVAL,.NLINES,.TEXT)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMTEXT.m

-              r628
+              r636
 PXRMTEXT ; SLC/PKR - Text formatting utility routines. ;07/19/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMTEXT ; SLC/PKR - Text formatting utility routines. ;11/03/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;============================================
+ ;================================================================
 NEWLINE ;Put TEXT on a new line to the output, make sure it does not end
  ;with a " ".
 …
+ Q
+ ;
  ;============================================
+ ;================================================================
 BLANK ;Add a blank line (line containing just " ") to the output.
  S NOUT=NOUT+1,TEXTOUT(NOUT)=" "
 …
+ Q
+ ;
  ;============================================
+ ;================================================================
 CHECKLEN(WORD) ;Check to see if adding the next word makes the line too long.
  ;If it does add it to the output and start a new line.
 …
+ Q
+ ;
+ ;============================================
+COLFMT(FMTSTR,TEXTSTR,PC,NL,OUTPUT) ;Columnar text formatter.
+ ;FMTSTR - format string; ^ separated string for each column in the
+ ;output. 35R2 defines a right justified column 35 characters wide
+ ;with 2 blank spaces following. Columns can be centered (C) left
+ ;justified (L) or right justified (R).
+ ;TEXTSTR - string to be formated
+ ;PC - the pad character
+ ;NL - number of lines of output
+ ;OUTPUT - array containing output lines.
+ N COLOUT,ENTRY,FMT,JND,JUS,IND,LEN,NCOL,NLO,NROW,SP,TEMP,TEXT,WIDTH,WPSP
+ S NCOL=$L(FMTSTR,U),NROW=1
+ F IND=1:1:NCOL D
+ . S FMT=$P(FMTSTR,U,IND)
+ . S JUS(IND)=$S(FMT["C":"C",FMT["L":"L",FMT["R":"R",1:"C")
+ . S WIDTH(IND)=$P(FMT,JUS(IND),1)
+ . S SP(IND)=$P(FMT,JUS(IND),2)
+ . S WPSP(IND)=WIDTH(IND)+SP(IND)
+ F IND=1:1:NCOL D
+ . S ENTRY=$S(JUS(IND)="C":"CJ",JUS(IND)="L":"LJ",JUS(IND)="R":"RJ")
+ . S TEMP=$P(TEXTSTR,U,IND)
+ . S LEN=$L(TEMP)
+ . I LEN'>WIDTH(IND) D
+ .. S TEMP=$$@ENTRY^XLFSTR(TEMP,WIDTH(IND),PC)
+ .. S COLOUT(1,IND)=TEMP_$$LJ^XLFSTR("",SP(IND)," ")
+ . I LEN>WIDTH(IND) D
+ .. D FORMATS(1,WIDTH(IND),TEMP,.NLO,.TEXTOUT)
+ .. F JND=1:1:NLO D
+ ... S TEMP=$$@ENTRY^XLFSTR(TEXTOUT(JND),WIDTH(IND),PC)
+ ... S COLOUT(JND,IND)=TEMP_$$LJ^XLFSTR("",SP(IND)," ")
+ .. I NLO>NROW S NROW=NLO
+ F IND=1:1:NROW D
+ . S TEXT=""
+ . F JND=1:1:NCOL D
+ .. I $D(COLOUT(IND,JND)) S TEXT=TEXT_COLOUT(IND,JND)
+ .. E  S TEXT=TEXT_$$LJ^XLFSTR("",(WPSP(JND))," ")
+ . S OUTPUT(IND)=TEXT
+ S NL=NROW
+ Q
+ ;
+ ;============================================
+COLFMTA(FMTSTR,INPUT,PC,NL,OUTPUT) ;Columnar text formatter.
+ ;Array version of COLFMT. Input array is ^TMP($J,INPUT,M) and
+ ;output is ^TMP(OUTPUT,$J,N,0).
+ N COLOUT,ENTRY,FMT,JND,JUS,IND,LEN,NCOL,NLO,NROW,NUM
+ N SP,TEMP,TEXT,WIDTH,WPSP
+ S NCOL=$L(FMTSTR,U)
+ F IND=1:1:NCOL D
+ . S FMT=$P(FMTSTR,U,IND)
+ . S JUS(IND)=$S(FMT["C":"C",FMT["L":"L",FMT["R":"R",1:"C")
+ . S WIDTH(IND)=$P(FMT,JUS(IND),1)
+ . S SP(IND)=$P(FMT,JUS(IND),2)
+ . S WPSP(IND)=WIDTH(IND)+SP(IND)
+ S NL=0,NUM=""
+ F  S NUM=$O(^TMP($J,INPUT,NUM)) Q:NUM=""  D
+ . K COLOUT
+ . S NROW=1
+ . F IND=1:1:NCOL D
+ .. S ENTRY=$S(JUS(IND)="C":"CJ",JUS(IND)="L":"LJ",JUS(IND)="R":"RJ")
+ .. S TEMP=$P(^TMP($J,INPUT,NUM),U,IND)
+ .. S LEN=$L(TEMP)
+ .. I LEN'>WIDTH(IND) D
+ ... S TEMP=$$@ENTRY^XLFSTR(TEMP,WIDTH(IND),PC)
+ ... S COLOUT(1,IND)=TEMP_$$LJ^XLFSTR("",SP(IND)," ")
+ .. I LEN>WIDTH(IND) D
+ ... D FORMATS(1,WIDTH(IND),TEMP,.NLO,.TEXTOUT)
+ ... F JND=1:1:NLO D
+ .... S TEMP=$$@ENTRY^XLFSTR(TEXTOUT(JND),WIDTH(IND),PC)
+ .... S COLOUT(JND,IND)=TEMP_$$LJ^XLFSTR("",SP(IND)," ")
+ ... I NLO>NROW S NROW=NLO
+ . F IND=1:1:NROW D
+ .. S TEXT=""
+ .. F JND=1:1:NCOL D
+ ... I $D(COLOUT(IND,JND)) S TEXT=TEXT_COLOUT(IND,JND)
+ ... E  S TEXT=TEXT_$$LJ^XLFSTR("",(WPSP(JND))," ")
+ .. S NL=NL+1,^TMP(OUTPUT,$J,NL,0)=TEXT
+ Q
+ ;
+ ;============================================
+ ;================================================================
 FORMAT(LM,RM,NIN,TEXTIN,NOUT,TEXTOUT) ;Format the text in TEXTIN so it has
  ;a left margin of LM and a right margin of RM. The formatted text
 …
+ Q
+ ;
  ;============================================
+ ;================================================================
 FORMATS(LM,RM,TEXTLINE,NOUT,TEXTOUT) ;Take a single line of input text
  ;and format it.
 …
+ Q
+ ;
- ;============================================
-LMFMTSTR(VALMDDF,JSTR) ;The List Manager variable VALMDDF contains the
- ;list template caption column formatting information. It contains
- ;the starting column and the width if the form
- ;VALMDDF(COLUMN NAME)=COLUMN NAME^COLUMN^WIDTH^CAPTION^VIDEO^SCROLL
- ;LOCK. JUSSTR, which is optional,is the justification for each column;
- ;(L=left, C=center, R=right) the default is center. Use this information
- ;to build the format string for the column formatter COLFMT.
- N CN,COL,FMTSTR,IND,JC,JUSSTR,PLCOL,SCOL,SP,TEMP,WIDTH
- ;Sort by columns
- S IND=""
- F  S IND=$O(VALMDDF(IND)) Q:IND=""  D
- . S TEMP=VALMDDF(IND)
- . S COL($P(TEMP,U,2))=$P(TEMP,U,3)
- S JUSSTR=$G(JSTR)
- S (CN,PLCOL,SCOL,SP)=0
- S FMTSTR=""
- S SCOL=0
- F  S SCOL=$O(COL(SCOL)) Q:SCOL=""  D
- . S CN=CN+1
- . S WIDTH=COL(SCOL)
- . I CN=1 S PLCOL=WIDTH
- . E  S SP=SCOL-PLCOL-1,FMTSTR=FMTSTR_SP_U,PLCOL=SCOL+WIDTH-1
- . S JC=$E(JUSSTR,CN)
- . I JC="" S JC="C"
- . S TEMP=WIDTH_JC
- . S FMTSTR=FMTSTR_TEMP
- Q FMTSTR
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMTMED.m

-              r628
+              r636
 PXRMTMED ; SLC/PKR/PJH - Edit a reminder term. ;04/18/2007
  ;;2.0;CLINICAL REMINDERS;**1,4,6**;Feb 04, 2005;Build 123
+PXRMTMED ; SLC/PKR/PJH - Edit a reminder term. ;01/30/2006
+ ;;2.0;CLINICAL REMINDERS;**1,4**;Feb 04, 2005;Build 21
+ ;
  ;=======================================================
 …
  N CFIEN,GLOB,IEN,LIST,NODE,TERMSTAT,VF,WPIEN
  N DEF,DEF1,DEF2,STATUS
- S DIE("NO^")="OUTOK"
  S STATUS=0
  D DEF^PXRMRUTL("811.52",.DEF,.DEF1,.DEF2)
 …
  S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB=""
  I GLOB="PXRMD(811.4," S CFIEN=$P($P(Y,U,2),";",1) D
+ . I $D(^PXRMD(811.4,CFIEN,1))>0 D
+ .. W !!,"Computed Finding Description:" S WPIEN=0
+ .. F  S WPIEN=$O(^PXRMD(811.4,CFIEN,1,WPIEN)) Q:+WPIEN'>0  D
+ ... W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))
+ . E  W !!,"No description defined for this computed finding"
+ . W !
+ I GLOB="YTT(601.71," D WARN^PXRMMH
+ .I $D(^PXRMD(811.4,CFIEN,1))>0 D
+ ..W !!,"Computed Finding Description:" S WPIEN=0
+ ..F  S WPIEN=$O(^PXRMD(811.4,CFIEN,1,WPIEN)) Q:+WPIEN'>0  D
+ ...W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))
+ .E  W !!,"No description defined for this computed finding"
+ .W !
  W !,"Editing Finding Number: "_$G(DA)
  ;Finding record fields
 …
  I VF S DR=DR_";28"
  ;Mental Health - scale
  I GLOB="YTT(601.71," S DR=DR_";13"
+ I GLOB="YTT(601," S DR=DR_";13"
  ;Radiology procedure
  I GLOB="RAMIS(71," S STATUS=1
 …
  ;Edit finding record
  D ^DIE
  I STATUS=1,$D(DA)>0,$D(Y)=0 D STATUS^PXRMSTA1(.DA,"T")
+ I STATUS=1,$D(DA)>0 D STATUS^PXRMSTA1(.DA,"T")
  S $P(^PXRMD(811.5,IEN,20,0),U,3)=0
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMUTIL.m

-              r628
+              r636
 PXRMUTIL ; SLC/PKR/PJH - Utility routines for use by PXRM. ;10/02/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;
  ;=================================
+PXRMUTIL ; SLC/PKR/PJH - Utility routines for use by PXRM. ;05/25/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;===========================================================
 ATTVALUE(STRING,ATTR,SEP,AVSEP) ;STRING contains a list of attribute value
  ;pairs. Each pair is separated by SEP and the attribute value pair
 …
  Q VALUE
+ ;
+ ;=================================
+ACOPY(REF,OUTPUT) ;Copy all the descendants of the array reference into a linear
+ ;array. REF is the starting array reference, for example A or
+ ;^TMP("PXRM",$J). OUTPUT is the linear array for the output. It
+ ;should be in the form of a closed root, i.e., A() or ^TMP($J,).
+ ;Note OUTPUT cannot be used as the name of the output array.
+ N DONE,IND,LEN,NL,OROOT,OUT,PROOT,ROOT,START,TEMP
+ I REF="" Q
+ S NL=0
+ S OROOT=$P(OUTPUT,")",1)
+ S PROOT=$P(REF,")",1)
+ ;Build the root so we can tell when we are done.
+ S TEMP=$NA(@REF)
+ S ROOT=$P(TEMP,")",1)
+ S REF=$Q(@REF)
+ I REF'[ROOT Q
+ S DONE=0
+ F  Q:(REF="")!(DONE)  D
+ . S START=$F(REF,ROOT)
+ . S LEN=$L(REF)
+ . S IND=$E(REF,START,LEN)
+ . S NL=NL+1
+ . S OUT=OROOT_NL_")"
+ . S @OUT=PROOT_IND_"="_@REF
+ . S REF=$Q(@REF)
+ . I REF'[ROOT S DONE=1
+ Q
+ ;
+ ;=================================
+ ;===========================================================
 AWRITE(REF) ;Write all the descendants of the array reference.
  ;REF is the starting array reference, for example A or ^TMP("PXRM",$J).
 …
+ Q
+ ;
  ;=================================
+ ;===========================================================
 DIP(VAR,IEN,PXRMROOT,FLDS) ;Do general inquiry for IEN return formatted
  ;output in VAR. VAR can be either a local variable or a global.
 …
+ Q
+ ;
  ;=================================
+ ;===========================================================
 FNFR(ROOT) ;Given the root of a file return the file number.
  Q +$P(@(ROOT_"0)"),U,2)
+ ;
  ;=================================
+ ;===========================================================
 NTOAN(NUMBER) ;Given an integer N return an alphabetic string that can be
  ;used for sorting. This will be modulus 26. For example N=0 returns
 …
  Q ANUM
+ ;
+ ;=================================
+RMEHIST(FILENUM,IEN) ;Remove the edit history for a reminder file.
+ I (FILENUM<800)!(FILENUM>811.9)!(FILENUM=811.8) Q
+ N DA,DIK,GLOBAL,ROOT
+ S GLOBAL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
+ ;Edit History is stored in node 110 for all files.
+ S DA(1)=IEN
+ S DIK=GLOBAL_IEN_",110,"
+ S ROOT=GLOBAL_IEN_",110,DA)"
+ S DA=0
+ F  S DA=+$O(@ROOT) Q:DA=0  D ^DIK
+ Q
+ ;
+ ;=================================
+ ;===========================================================
 SEHIST(FILENUM,ROOT,IEN) ;Set the edit date and edit by and prompt the
  ;user for the edit comment.
 …
+ Q
+ ;
  ;=================================
+ ;===========================================================
 SFRES(SDIR,NRES,FIEVAL) ;Save the finding result.
  I NRES=0 S FIEVAL=0 Q
 …
+ Q
+ ;
  ;=================================
+ ;===========================================================
 SSPAR(FIND0,NOCC,BDT,EDT) ;Set the finding search parameters.
  S BDT=$P(FIND0,U,8),EDT=$P(FIND0,U,11),NOCC=$P(FIND0,U,14)
  I +NOCC=0 S NOCC=1
+ I NOCC="" S NOCC=1
  ;Convert the dates to FileMan dates.
  S BDT=$S(BDT="":0,BDT=0:0,1:$$CTFMD^PXRMDATE(BDT))
 …
  ;If EDT does not contain a time set it to the end of the day.
  I EDT'["." S EDT=EDT_".235959"
+ I $G(PXRMDDOC)'=1 Q
+ S ^TMP("PXRMDDOC",$J,$P(FIND0,U,1,11))=BDT_U_EDT
+ Q
+ ;
+ ;=================================
+ Q
+ ;
+ ;===========================================================
 STRREP(STRING,TS,RS) ;Replace every occurrence of the target string (TS)
  ;in STRING with the replacement string (RS).
 …
  Q STR
+ ;
  ;=================================
+ ;===========================================================
 VEDIT(ROOT,IEN) ;This is used as a DIC("S") screen to select which entries
  ;a user can edit.

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMVITL.m

-              r628
+              r636
 PXRMVITL ; SLC/PKR - Handle vitals findings. ;09/20/2007
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMVITL ; SLC/PKR - Handle vitals findings. ;10/21/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;===========================================================
 …
+ ;
  ;===========================================================
+GETDATA(DAS,FIEVT) ;Return data for a GMRV Vital Measurement entry.
+ N EM,IND,GMRVDATA,STOP,TEMP,TYPE
+GETDATA(DAS,FIEVT) ;Return the value, which is Rate, for a specified
+ ;GMRV Vital Measurement entry.
+ N IND,GMRVDATA,TEMP
  ;DBIA #3647
  D EN^GMVPXRM(.GMRVDATA,DAS,"I")
  I $P(GMRVDATA(1),U,1)=-1 D  Q
  . S ^TMP("PXRMXMZ",$J,1,0)="Found GMRV entry "_DAS_" in the index, but it does not exist in ^GMR(120.5"
+ . S ^TMP("PXRMXMZ",$J,1,0)="Found GMRV entry "_DAS_" in the index, but it does not exist in ^GMRV(120.5"
  . D SEND^PXRMMSG("Bad entry in Vitals index.")
+ S FIEVT("TYPE")=$$EXTERNAL^DILFD(120.5,.03,"",GMRVDATA(3),.EM)
+ ;DBIA #10040
+ S TEMP=$S(+GMRVDATA(5)'=0:^SC(GMRVDATA(5),0),1:"")
+ S FIEVT("HOSPITAL LOCATION")=$P(TEMP,U,1)
+ S FIEVT("LOCATION TYPE")=$P(TEMP,U,3)
+ S STOP=$P(TEMP,U,7)
+ S FIEVT("ENTERED BY")=$P(^VA(200,GMRVDATA(6),0),U,1)
+ S FIEVT("TYPE")=$P(GMRVDATA(3),U,1)
  S (FIEVT("RATE"),FIEVT("VALUE"))=$P(GMRVDATA(7),U,1)
  S IND=0
 …
  .;DBIA #4504
  . I TEMP'="" S FIEVT("QUALIFIER",IND)=$P($G(^GMRD(120.52,+TEMP,0)),U,1)
- ;DBIA #557
- I STOP'="" S FIEVT("STOP CODE")=$P(^DIC(40.7,STOP,0),U,1,2)
- E  S FIEVT("STOP CODE")=""
+ Q
+ ;
 …
  ;maintenance output.
  N DATE,EM,IND,JND,NOUT,RATE,TEMP,TEXTOUT,TYPE
+ S TYPE=$$EXTERNAL^DILFD(120.5,.03,"",IFIEVAL("TYPE"),.EM)
  S NLINES=NLINES+1
  S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Vital Measurement: "_IFIEVAL("TYPE")
+ S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Vital Measurement: "_TYPE
  S IND=0
  F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMVPTR.m

-              r628
+              r636
 PXRMVPTR ; SLC/PKR - Routines for dealing with variable pointers. ; 02/06/2001
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ;==================================================
 …
  ;indexed by the file number.
  N FN,IND,ROOT,TEMP
- ;DBIA #2991
  S IND=0
  F  S IND=$O(^DD(FILE,FIELD,"V",IND)) Q:+IND=0  D

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMVSIT.m

-              r628
+              r636
 PXRMVSIT ; SLC/PKR - Visit related info for reminders. ;02/22/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMVSIT ; SLC/PKR - Visit related info for reminders. ;07/06/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;======================================================
 GETDATA(DA,DATA,SVALUE) ;Return data for a specific Visit file entry.
+GETDATA(DA,FIEVT,SVALUE) ;Return data for a specific Visit file entry.
  ;DBIA #2028 for Visit file.
  N DONE,IEN,HTEMP,LOE,TEMP
+ N HTEMP,TEMP
  S TEMP=^AUPNVSIT(DA,0)
+ S DATA("VISIT")=DA
+ S DATA("DATE VISIT CREATED")=$P(TEMP,U,2)
+ S DATA("DFN")=$P(TEMP,U,5)
+ S (DATA("LOC. OF ENCOUNTER"),LOE)=$P(TEMP,U,6)
+ ;DBIA #10090
+ S DATA("STATION NUMBER")=$$GET1^DIQ(4,LOE,99)
+ S DATA("OFFICAL VA NAME")=$$GET1^DIQ(4,LOE,100)
+ S DATA("SERVICE CATEGORY")=$P(TEMP,U,7)
+ I $G(SVALUE) S DATA("VALUE")=$P(TEMP,U,7)
+ S DATA("HOSPITAL LOCATION")=$P(TEMP,U,22)
+ S FIEVT("VISIT")=DA
+ S FIEVT("DATE VISIT CREATED")=$P(TEMP,U,2)
+ S FIEVT("DFN")=$P(TEMP,U,5)
+ S FIEVT("LOC. OF ENCOUNTER")=$P(TEMP,U,6)
+ S FIEVT("SERVICE CATEGORY")=$P(TEMP,U,7)
+ I $G(SVALUE) S FIEVT("VALUE")=$P(TEMP,U,7)
+ S FIEVT("HOSPITAL LOCATION")=$P(TEMP,U,22)
  ;DBIA #10040, #2804
  I $G(DATA("HOSPITAL LOCATION"))="" S HTEMP=""
  E  S HTEMP=^SC(DATA("HOSPITAL LOCATION"),0)
  S DATA("HLOC")=$P(HTEMP,U,1)
  S DATA("DSS ID")=$P(TEMP,U,8)
  I DATA("DSS ID")="" S DATA("DSS ID")=$P(HTEMP,U,7)
+ I $G(FIEVT("HOSPITAL LOCATION"))="" S HTEMP=""
+ E  S HTEMP=^SC(FIEVT("HOSPITAL LOCATION"),0)
+ S FIEVT("HLOC")=$P(HTEMP,U,1)
+ S FIEVT("DSS ID")=$P(TEMP,U,8)
+ I FIEVT("DSS ID")="" S FIEVT("DSS ID")=$P(HTEMP,U,7)
  ;DBIA #557
  I DATA("DSS ID")'="" S DATA("STOP CODE")=$P(^DIC(40.7,DATA("DSS ID"),0),U,2)
  S DATA("OUTSIDE LOCATION")=$G(^AUPNVSIT(DA,21))
  S DATA("COMMENTS")=$G(^AUPNVSIT(DA,811))
+ I FIEVT("DSS ID")'="" S FIEVT("STOP CODE")=$P(^DIC(40.7,FIEVT("DSS ID"),0),U,2)
+ S FIEVT("OUTSIDE LOCATION")=$G(^AUPNVSIT(DA,21))
+ S FIEVT("COMMENTS")=$G(^AUPNVSIT(DA,811))
  ;DBIA #4850
+ S DATA("STATUS")=$$STATUS^SDPCE(DA)
+ ;Get the primary provider.
+ ;DBIA #3455 for V PROVIDER
+ S DATA("PRIMARY PROVIDER")="",IEN="",DONE=0
+ F  S IEN=$O(^AUPNVPRV("AD",DA,IEN)) Q:(DONE)!(IEN="")  D
+ . S TEMP=^AUPNVPRV(IEN,0)
+ . I $P(TEMP,U,4)="P" S DATA("PRIMARY PROVIDER")=$P(TEMP,U,1),DONE=1
+ S FIEVT("STATUS")=$$STATUS^SDPCE(DA)
+ Q
+ ;
 …
  ;NO-SHOW
  ;NO-SHOW & AUTO RE-BOOK
- ;NULL
  N STATUS,VALID
  ;DBIA #4850
  S STATUS=$P($$STATUS^SDPCE(VIEN),U,2)
  S VALID=$S(STATUS["CANCELLED":0,STATUS["DELETED":0,STATUS["NO ACTION":0,STATUS["NO-SHOW":0,STATUS="":0,1:1)
+ S VALID=$S(STATUS["CANCELLED":0,STATUS["DELETED":0,STATUS["NO ACTION":0,STATUS["NO-SHOW":0,1:1)
  Q VALID
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXD.m

-              r628
+              r636
 PXRMXD ; SLC/PJH - Reminder Due reports DRIVER ;11/27/2006
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXD ; SLC/PJH - Reminder Due reports DRIVER ;06/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
 START ; Arrays and strings
 …
  N DBDOWN,DBDUZ,DBERR,PXRMLIST,PXRMLIS1,Y
  N PLISTPUG
  N PXRMTPAT,PXRMDPAT,PXRMPML
+ N PXRMTPAT,PXRMDPAT
+ ;
  S PXRMRT="PXRMX",PXRMTYP="X",PXRMFCMB="N",PXRMLCMB="N",PXRMTCMB="N"
 …
  .D LIT,TOTALS^PXRMXSD(.PXRMTOT,LIT1,LIT2,LIT3)
+ ;
-MLOC     ;Print Locations empty location at the end of the report
- W !
- S DIR(0)="Y",DIR("B")="YES",DIR("A")="Print locations with no patients"
- D ^DIR
- I Y="^^" G EXIT
- I Y=U G:PXRMREP="D" SSN G TOT
- S PXRMPML=Y
+ ;
  ;Reminder Category/Individual Reminder Selection
 RCAT ;
  D RCAT^PXRMXSU(.PXRMRCAT,.PXRMREM) I $D(DTOUT) G EXIT
+ ;I $D(DUOUT) G:PXRMREP="D" SSN G TOT
+ I $D(DUOUT) G MLOC
+ I $D(DUOUT) G:PXRMREP="D" SSN G TOT
+ ;
  ;Create combined reminder list

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXDT1.m

-              r628
+              r636
 PXRMXDT1 ; SLC/PJH - Build Patient list SUBROUTINES;08/16/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXDT1 ; SLC/PJH - Build Patient list SUBROUTINES;07/10/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ; Called by label from PXRMXSEO,PXRMXSE
 …
+ Q
+ ;
 ERRMSG(TYPE) ;
+DBDOWN(TYPE) ;
  N CNT,CNT1,CNT2,STR,NLINES,OUTPUT,TIME
  K ^TMP("PXRMXMZ",$J)
 …
  I TYPE="C" D  Q
  .M ^TMP("PXRMXMZ",$J)=^TMP($J,"PXRM CNBD")
  .D SEND^PXRMMSG("REMINDER REPORTS CNBD PATIENT LIST ("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1)
+ .D SEND^PXRMMSG("COULD NOT BE DETERMINED PATIENTS("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1)
  I 'PXRMQUE D
  .S STR(1)="The Reminders Due Report "_$G(TITLE)_" requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_" for the following reason(s):"
 …
  .F CNT=1:1:NLINES W !,OUTPUT(CNT)
  I PXRMQUE D
  .S ^TMP("PXRMXMZ",$J,1,0)="The Reminders Due Report "_$G(TITLE)_" requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_"was cancelled for the following reason(s):"
+ .S ^TMP("PXRMXMZ",$J,1,0)="The Reminders Due Report "_$G(TITLE)_" requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_" for the following reason(s):"
  .F  S CNT=$O(DBERR(CNT)) Q:CNT'>0  S ^TMP("PXRMXMZ",$J,CNT1,0)=DBERR(CNT),CNT1=CNT1+1
  .D SEND^PXRMMSG("Cancelled Reminders Due Report ("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1)
+ .D SEND^PXRMMSG("Cancelled Reminders Due Report("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1)
  .S ZTSTOP=1
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXGPR.m

-              r628
+              r636
 PXRMXGPR ; SLC/PJH - Reminder Due print calls ;11/16/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXGPR ; SLC/PJH - Reminder Due print calls ;01/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;Called from PXRMXPR
 …
+ ;
  ;form feed to new page
 PAGE I ($E(IOST,1,2)="C-")&(IO=IO(0))&(PAGE>0) D
+PAGE I ($E(IOST)="C")&(IO=IO(0))&(PAGE>0) D
  .S DIR(0)="E"
  .W !
 …
  W:$D(IOF)&(PAGE>0) @IOF
  S PAGE=PAGE+1,FIRST=0
  I $E(IOST,1,2)="C-",IO=IO(0) W @IOF
+ I $E(IOST)="C",IO=IO(0) W @IOF
  E  W !
  N TEMP,TEXTLEN

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXGUT.m

-              r628
+              r636
 PXRMXGUT ; SLC/PJH - General utilities for reminder reports; 11/16/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXGUT ; SLC/PJH - General utilities for reminder reports; 05/31/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;=======================================
 EOR ;End of report display.
  I $E(IOST,1,2)="C-",IO=IO(0) D
+ I $E(IOST)="C",IO=IO(0) D
  . S DIR(0)="EA"
  . S DIR("A")="End of the report. Press ENTER/RETURN to continue..."
 …
+ ;
  ;=======================================
+TIMING ;Print report timing data.
+ N IND
+ W !!,"Report timing data:"
+ S IND=""
+ F  S IND=$O(^XTMP(PXRMXTMP,"TIMING",IND)) Q:IND=""  W !," ",^XTMP(PXRMXTMP,"TIMING",IND)
+ Q
+VLIST(SLIST,LIST,MESSAGE) ;Make sure all the elements of LIST are in
+ ;SLIST.  If they are, then LIST is valid.  The elements of LIST can be
+ ;separated by commas and spaces.
+ N IC,LE,LEN,VALID
+ S LIST=$TR(LIST,",","")
+ S LIST=$TR(LIST," ","")
+ ;Make the test case insensitive.
+ S SLIST=$$UP^XLFSTR(SLIST)
+ S LIST=$$UP^XLFSTR(LIST)
+ S VALID=1
+ S LEN=$L(LIST)
+ I LEN=0 D
+ . W !,"The list is empty!"
+ . S VALID=0
+ F IC=1:1:LEN D
+ . S LE=$E(LIST,IC,IC)
+ . I SLIST'[LE D
+ .. W !,LE,MESSAGE
+ .. S VALID=0
+ Q VALID
+ ;
  ;=======================================
 …
  Q STR
+ ;
- ;=======================================
-VLIST(SLIST,LIST,MESSAGE) ;Make sure all the elements of LIST are in
- ;SLIST.  If they are, then LIST is valid.  The elements of LIST can be
- ;separated by commas and spaces.
- N IC,LE,LEN,VALID
- S LIST=$TR(LIST,",","")
- S LIST=$TR(LIST," ","")
- ;Make the test case insensitive.
- S SLIST=$$UP^XLFSTR(SLIST)
- S LIST=$$UP^XLFSTR(LIST)
- S VALID=1
- S LEN=$L(LIST)
- I LEN=0 D
- . W !,"The list is empty!"
- . S VALID=0
- F IC=1:1:LEN D
- . S LE=$E(LIST,IC,IC)
- . I SLIST'[LE D
- .. W !,LE,MESSAGE
- .. S VALID=0
- Q VALID
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXPR.m

-              r628
+              r636
 PXRMXPR ; SLC/PJH - Print Reminder Due report. ;11/27/2006
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXPR ; SLC/PJH - Print Reminder Due report. ;01/14/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ; Called/Jobbed after PXRMXSE1
 …
  I ('DONE),$O(^XTMP(PXRMXTMP,PX,""))="" D NULL^PXRMXGPR G EXIT
  ; Report selected patient sample with no patients
  I $D(MISSED),PXRMPML=1 D MISSED^PXRMXPR1(0,.MISSED)
+ I $D(MISSED) D MISSED^PXRMXPR1(0,.MISSED)
+ ;
  ;Print Patient List
 …
  I $D(^XTMP(PXRMXTMP,"ERROR"))>0!($D(^XTMP(PXRMXTMP,"CNBD"))>0) D ERROR^PXRMXBSY
 EXIT ;
- D TIMING^PXRMXGUT
  D EXIT^PXRMXGUT
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXPR1.m

-              r628
+              r636
 PXRMXPR1 ; SLC/AGP - Print Reminder Due report carryover code. ;01/05/2006
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;Patient list display
 …
  N DATA,IC,LTYPE,MARK
  S IC=""
  I PXRMSEL="P" D  Q
+ I PXRMSEL="P" D
  . F  S IC=$O(PXRMPRV(IC)) Q:IC=""  D
  .. S DATA=PXRMPRV(IC)

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXQUE.m

-              r628
+              r636
 PXRMXQUE ; SLC/PJH - Reminder reports general queuing routine.;03/23/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXQUE ; SLC/PJH - Reminder reports general queuing routine.;02/24/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ;Determine whether the report should be queued.
+        ;Determine whether the report should be queued.
 JOB ;
  N %ZIS S %ZIS="Q"
 …
  Q $G(ZTSK)
+ ;
+DEVICE(RTN,DESC,SAVE,%ZIS,RETZTSK) ;
+ ;Pass RETZTSK as number such as 1 if you want to get ZTSK.
+ N ZTSK
+DEVICE(ZTRTN,ZTDESC,ZTSAVE,%ZIS,ZTSK) ;
  W !
+ D EN^XUTMDEVQ(RTN,DESC,.SAVE,.%ZIS,RETZTSK)
+ I $D(ZTSK) W !!,DESC," has been queued, task number "_ZTSK H 2
+ Q $G(ZTSK)
+ D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.ZTSK)
+ I $D(ZTSK)>1 W !!,ZTDESC," has been queued, task number "_$G(ZTSK) H 2
+ I $G(ZTSK)="" S ZTSK=0
+ Q ZTSK
+ ;
  ;=======================================================================
 …
  S ZTSAVE("PXRMDPAT")=""
  I +$G(PXRMIDOD)>0 S ZTSAVE("PXRMIDOD")=""
- S ZTSAVE("PXRMPML")=""
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXSC.m

-              r628
+              r636
 PXRMXSC ; SLC/PJH - Reminder reports service category selection ;12/18/2006
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXSC ; SLC/PJH - Reminder reports service category selection ;11/03/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
 SCAT ;Get the list of service categories.
 …
  D HELP^DIE(9000010,"",.07,"S","SCA")
  S NSC=SCA("DIHELP")
+ S DIR("?")=U_"D SCATHELP^PXRMXSC"
+ S DIR("?")=" "
+ S DIR("?",1)="The possible service categories for the report are:"
+ S JC=0
+ F IC=2:1:NSC D
+ . S X=$P(SCA("DIHELP",IC)," ",1)
+ . I PCESVC="" S PCESVC=X
+ . E  S PCESVC=PCESVC_","_X
+ . S JC=JC+1
+ . S DIR("?",JC)=SCA("DIHELP",IC)
+ S NSC=JC
  S DIR("??")=U_"D SCATHELP^PXRMXSC"
 SCATP ;
 …
+ ;
  ;======================================================
+SCATHELP ;? help for service categories.
+ N ARRAY,IC,JC,NSC,PCESVC
+ S PCESVC=""
+ D HELP^DIE(9000010,"",.07,"S","SCA")
+ S NSC=SCA("DIHELP")
+ S JC=0
+ F IC=2:1:NSC D
+ . S X=$P(SCA("DIHELP",IC)," ",1)
+ . I PCESVC="" S PCESVC=X
+ . E  S PCESVC=PCESVC_","_X
+ . S JC=JC+1
+ . S ARRAY(JC)=SCA("DIHELP",IC)
+ S NSC=JC
+SCATHELP ;?? help for service categories.
  W !!,"Enter the letter(s), separated by commas, corresponding to the desired service"
  W !,"category or categories. For example A,H,T,E would allow only encounters with"
  W !,"service categories of ambulatory, hospitalization, telecommunications, and"
  W !,"event (historical) to be included."
- W !!,"The possible service categories for the report are:",!
- F IC=1:1:NSC W !,ARRAY(IC)
+ Q
+ ;

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXSE1.m

-              r628
+              r636
 PXRMXSE1 ; SLC/PJH - Build Patient lists for Reminder Due report; 08/16/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXSE1 ; SLC/PJH - Build Patient lists for Reminder Due report; 01/25/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ; Called/jobbed from PXRMXD
 …
  ..N DA,DIK S DA=PXRMLIS1,DIK="^PXRMXP(810.5," D ^DIK
  .;Otherwise create patient list
  .D UPDLST^PXRMRULE("PXRMXPAT",PXRMLIS1,"","","",PXRMDPAT,PXRMTPAT)
+ .D UPDLST^PXRMRULE("PXRMXPAT",PXRMLIS1,"","")
  .S $P(^PXRMXP(810.5,PXRMLIS1,0),U,9)=1
  K ^TMP($J,"PXRMXPAT")
 …
+ ;
 XTMP(START) ;
+ N CNT,CCNT,DDAT,INP,ITEM,LIT,LSSN,MCNBD,MCNBDR,NAME
+ N SUB,STATUS,TEMP,TEMP1,TEXT
+ N CNT,CCNT,DDAT,INP,ITEM,LIT,LSSN,MCNBD,MCNBDR,NAME,SUB,STATUS,TEMP,TEMP1
  K ^TMP($J,"PXRM CNBD")
  S CCNT=0,MCNBD=$G(^PXRM(800,1,"MIERR")),MCNBDR=0
 …
  ....I PXRMREP="D" D SDET^PXRMXDT1(DFN,STATUS,NAM,FACILITY,INP)
  ....I PXRMREP="S" D SUM^PXRMXDT1(DFN,STATUS,FACILITY,NAM)
  I $D(^TMP($J,"PXRM CNBD"))>0 D ERRMSG^PXRMXDT1("C")
+ I $D(^TMP($J,"PXRM CNBD"))>0 D DBDOWN^PXRMXDT1("C")
  K ^TMP($J,"PXRM CNBD")
  S END=$H
+ S TEXT="Elapsed time for reminder evaluation: "_$$DETIME^PXRMXSL1(START,END)
+ S ^XTMP(PXRMXTMP,"TIMING","REMINDER EVALUATION")=TEXT
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Evaluating Reminders")
  ;I PXRMDBUG="Y" D DEBUG("DEBUG PATIENT DATA EVALUATION","DEBUG","^TMP($J,""PXRMDEBUG"")")
  K ^TMP($J,"PXRM PATIENT EVAL")

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXSL1.m

-              r628
+              r636
 PXRMXSL1 ; SLC/PJH - Process Visits/Appts Reminder Due report;02/07/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXSL1 ; SLC/PJH - Process Visits/Appts Reminder Due report;12/09/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ; Called from PXRMXSE
 …
  I '$D(PXRMFACN(HFAC)) Q ""
  Q HFAC
+ ;
-INACTCL(HLIEN,PXRMBDT) ;
- ;Check to see if clinic is inactivated before the start of
- ;the reporting period
- N INACT,REACT
- S INACT=+$P($G(^SC(HLIEN,"I")),U) I INACT=0 Q 0
- S REACT=+$P($G(^SC(HLIEN,"I")),U,2)
- I REACT'<INACT Q 0
- I INACT<PXRMBDT Q 1
- Q 0
+ ;
 INPADM ;
 …
+ ;
 BHLOC ;
+ N CLINIEN,END,FACILITY,NAM,HLIEN,I,START,TEXT
+ N INACT,REACT
+ N CLINIEN,END,FACILITY,NAM,HLIEN,I,START
  I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
  ;All inpatient, outpatient all location credit stop and encounter
 …
  .S HLIEN=0 F  S HLIEN=$O(^SC(HLIEN)) Q:HLIEN'>0  D
  ..S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
- ..I $$INACTCL(HLIEN,PXRMBDT)=1 Q
  ..S NAM=$P(^SC(HLIEN,0),U)
  ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
 …
  .S HLIEN=0 F  S HLIEN=$O(PXRMLOCN(HLIEN)) Q:HLIEN'>0  D
  ..S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
- ..I $$INACTCL(HLIEN,PXRMBDT)=1 Q
  ..S NAM=$P(^SC(HLIEN,0),U)
  ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
 …
  ..S HLIEN=0 F  S HLIEN=$O(^SC("AST",CLINIEN,HLIEN)) Q:HLIEN'>0  D
  ...S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
- ...I $$INACTCL(HLIEN,PXRMBDT)=1 Q
  ...S NAM=$P(^DIC(40.7,CLINIEN,0),U)_" "_$P(PXRMCS($G(PXRMCSN(CLINIEN))),U,3)
  ...I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
 …
  ..S HLIEN=0 F  S HLIEN=$O(^SC("ASCRPW",CGRPIEN,HLIEN)) Q:HLIEN'>0  D
  ...S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
- ...I $$INACTCL(HLIEN,PXRMBDT)=1 Q
  ...I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
  ...S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_$P(^SC(HLIEN,0),U)_U_CGRPIEN
  I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
  S END=$H
+ S TEXT="Elapsed time for building hospital locations: "_$$DETIME^PXRMXSL1(START,END)
+ S ^XTMP(PXRMXTMP,"TIMING","BUILDING HOSPITAL LOCATIONS")=TEXT
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
+ Q
+ ;
+DETIME(START,END) ;
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME(START,END,"Building Hospital Locations")
+ Q
+ ;
+DETIME(START,END,SECTION) ;
  N ETIME,TEXT
  S ETIME=$$HDIFF^XLFDT(END,START,2)
  I ETIME>90 D
  . S ETIME=$$HDIFF^XLFDT(END,START,3)
+ . S TEXT=ETIME
+ E  S TEXT=ETIME_" secs"
+ Q TEXT
+ . S TEXT="Elapsed time for "_SECTION_": "_ETIME
+ E  S TEXT="Elapsed time for "_SECTION_": "_ETIME_" secs"
+ D MES^XPDUTL(TEXT)
+ Q
+ ;
 OERR ;
 …
  I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
  N CNT,SCDT,LIST,SCERR,SCLIST,II,PCM,NAM,PNAM,PXRM,OK
- N FACILITY,NAM
  S SCDT("BEGIN")=PXRMSDT,SCDT("END")=PXRMSDT
  ;Include patient if in team on any day in range
 …
  ..I PXRMPRIM="P",($$PCASSIGN^PXRMXAP(DFN)'=1) Q
  ..;For detailed provider report get assoc clinic
+ ..I PXRMREP="D" S DCLN=$P(^TMP($J,"PCM",CNT),U,7) I +$G(DCLN)>0 D
+ ...S FACILITY=$$HFAC(DCLN)
+ ...S NAM=$P(^SC(DCLN,0),U)
+ ...S ^XTMP(PXRMXTMP,"HLOC",DCLN)=FACILITY_U_NAM
+ ..I PXRMREP="D" S DCLN=$P(^TMP($J,"PCM",CNT),U,7) I $G(DCLN)'="" S ^XTMP(PXRMXTMP,"HLOC",DCLN)=""
  ..I $G(DCLN)'="" S PXRMDCLN(DCLN)=""
  ..D UPD1(DFN,NAM,"FACILITY",+$G(DCLN))

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXSL2.m

-              r628
+              r636
 PXRMXSL2 ; SLC/AGP - Process Visits/Appts Reminder Due report; 08/16/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXSL2 ; SLC/AGP - Process Visits/Appts Reminder Due report; 06/07/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
 APPTS ;
 …
  N APPTDT,BDT,EDT,NODE,DFN,FACILITY,HLIEN,NAM
  S NAM="All Locations"
+ S BDT=PXRMBDT
+ ;I PXRMBDT["." S BDT=PXRMBDT
+ ;E  S BDT=PXRMBDT-.0001
+ I PXRMBDT["." S BDT=PXRMBDT
+ E  S BDT=PXRMBDT-.0001
  I PXRMEDT["." S EDT=PXRMEDT
  E  S EDT=PXRMEDT+.2359
 …
+ ;
 SDAM301(BD,ED,PXRMSEL,PXRMFD,PXRMREP) ;
  N ARRAY,BUSY,FACILITY,NAM,OPIEN,STATUS,TEXT
+ N ARRAY,BUSY,FACILITY,NAM,OPIEN,STATUS
  K ^TMP($J,"PXRM FUTURE APPT")
  K ^TMP($J,"PXRM FACILITY FUTURE APPT")
 …
  S COUNT=$$SDAPI^SDAMA301(.ARRAY)
  S END=$H
+ S TEXT="Elapsed time for call to the Scheduling Package: "_$$DETIME^PXRMXSL1(START,END)
+ S ^XTMP(PXRMXTMP,"TIMING","SCHEDULING")=TEXT
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Total amount of time to call the Scheduling Package")
  I COUNT<0 D  Q
  .N CNT
 …
  .F  S CNT=$O(^TMP($J,"SDAMA301",CNT)) Q:CNT'>0  D
  ..S DBERR(CNT)=$G(^TMP($J,"SDAMA301",CNT))
  .D ERRMSG^PXRMXDT1("E")
+ .D DBDOWN^PXRMXDT1("E")
+ ;
 LOOP ;
  I PXRMFD'="P"!(PXRMSEL'="L") Q
  N APPTDT,CIEN,DFN,FUTDT,NODE,TEXT,VIEN
+ N APPTDT,CIEN,DFN,FUTDT,NODE,VIEN
  ;LOOP THROUGH PATIENT
  S START=$H
 …
  S END=$H
  I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
+ S TEXT="Elapsed time for sorting SDAMA301 output: "_$$DETIME^PXRMXSL1(START,END)
+ S ^XTMP(PXRMXTMP,"TIMING","SCHEDULE SORT")=TEXT
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Sorting SDAMA301 Output")
+ Q
+ ;
  ;Scan visit file to build list of patients
 VISITS ;
- N BUSY,DAS,DATE,DFN,DS,END,ETIME,HLOC,NF
- N SC,START,TEMP,TEXT,TGLIST,TIME
- S START=$H
- K ^TMP($J,"PXRM PATIENT LIST")
- I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
- W !,"Building patient list "
- K ^TMP($J,"HLOCL"),^TMP($J,"PLIST")
- M ^TMP($J,"HLOCL")=^XTMP(PXRMXTMP,"HLOC")
- D FPLIST^PXRMLOCL(9000010,"HLOCL",-1,PXRMBDT,PXRMEDT,"PLIST")
- K ^TMP($J,"HLOCL")
- S DFN=""
- F  S DFN=$O(^TMP($J,"PLIST",DFN)) Q:DFN=""  D
- . S NF=0
- . F  S NF=$O(^TMP($J,"PLIST",DFN,NF)) Q:NF=""  D
- .. S TEMP=^TMP($J,"PLIST",DFN,NF)
- .. S SC=$P(TEMP,U,4)
- .. I '$D(PXRMSCAT(SC)) Q
- .. ;Remove test Patients
- .. I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q
- .. ;Remove deceased patients
- .. I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q
- .. S DAS=$P(TEMP,U,1),DATE=$P(TEMP,U,2),HLOC=$P(TEMP,U,3)
- .. S ^TMP($J,"PXRM PATIENT LIST",DFN,HLOC,DATE,DAS)=""
- K ^TMP($J,"PLIST")
- S END=$H
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
- S TEXT="Elapsed time for building patient list: "_$$DETIME^PXRMXSL1(START,END)
- S ^XTMP(PXRMXTMP,"TIMING","PATIENT LIST")=TEXT
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
- I PXRMREP="D" D SDAM301(PXRMBDT,PXRMEDT,PXRMSEL,PXRMFD,PXRMREP)
- I DBDOWN=1 Q
- S START=$H
- S BUSY=0
- I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
- N HLIEN,NAM,FACILITY,LSEL,NODE
- S DFN=0 F  S DFN=$O(^TMP($J,"PXRM PATIENT LIST",DFN)) Q:DFN'>0  D
- .S HLIEN=0
- .F  S HLIEN=$O(^TMP($J,"PXRM PATIENT LIST",DFN,HLIEN)) Q:HLIEN'>0  D
- ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Removing Invalid Encounter(s)",.BUSY)
- ..S NODE=$G(^XTMP(PXRMXTMP,"HLOC",HLIEN))
- ..S FACILITY=$P(NODE,U),NAM=$P(NODE,U,2)
- ..D TMP^PXRMXSL1(DFN,NAM,FACILITY,HLIEN)
- ..S TEMP=$P(PXRMLCSC,U,1)
- ..S LSEL=$S(TEMP="CS":$P(NODE,U,3),TEMP="GS":$P(NODE,U,3),1:HLIEN)
- ..D MARK^PXRMXSL1(LSEL)
- ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)=""
- S END=$H
- S TEXT="Elapsed time for removing invalid encounter(s): "_$$DETIME^PXRMXSL1(START,END)
- S ^XTMP(PXRMXTMP,"TIMING","REMOVING INVALID ENCOUNTER(S)")=TEXT
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
+ Q
+ ;
-VISITSO ; Old entry point
  N BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED
  N NFOUND,SC,TEMP,TEXT,TGLIST,TIME
+ N NFOUND,SC,TEMP,TGLIST,TIME
  N DOD,START,END
  S START=$H
 …
  S INVBD=9999999-$P(PXRMBDT,".",1),BTIME=+("."_$P(PXRMBDT,".",2))
  S INVED=9999999-$P(DEND,".",1),ETIME=+("."_$P(DEND,".",2))
  S DS=INVED-.000001
+ S DS=INVED-1
  S HLOC=""
  F  S HLOC=$O(^XTMP(PXRMXTMP,"HLOC",HLOC)) Q:HLOC=""  D
 …
  S END=$H
  I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
+ S TEXT="Elapsed time for building patient list: "_$$DETIME^PXRMXSL1(START,END)
+ S ^XTMP(PXRMXTMP,"TIMING","PATIENT LIST")=TEXT
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
+ I PXRMREP="D" D SDAM301(PXRMBDT,PXRMEDT,PXRMSEL,PXRMFD,PXRMREP)
+ ;D SDAM301(PXRMBDT-.0001,PXRMEDT,PXRMSEL,PXRMFD,PXRMREP)
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Building Patient List")
+ D SDAM301(PXRMBDT-.0001,PXRMEDT,PXRMSEL,PXRMFD,PXRMREP)
+ ;
  I DBDOWN=1 Q
  S START=$H
  S BUSY=0
+ I DBDOWN=1 Q
  N NODE
  I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
 …
  ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)=""
  S END=$H
- S TEXT="Elapsed time for removing invalid encounter(s): "_$$DETIME^PXRMXSL1(START,END)
- S ^XTMP(PXRMXTMP,"TIMING","REMOVING INVALID ENCOUNTER(S)")=TEXT
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
  I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Removing Invalid Encounter(s)")
+ Q

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTB.m

-              r628
+              r636
 PXRMXTB ; SLC/PJH - Reminder Reports Template Load ;11/27/2006
  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMXTB ; SLC/PJH - Reminder Reports Template Load ;08/01/2001
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
  ; Called from PXRMXD
 …
  S XREF("PXRMLCSC")=1.5
  S XREF("PXRMFD")=1.6
- S XREF("PXRMPML")=1.7
  S XREF("PXRMREM")=2
  S XREF("PXRMFAC")=3

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTD.m

-              r628
+              r636
 PXRMXTD ; SLC/PJH - Reminder Reports Template Display ;11/16/2007
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXTD ; SLC/PJH - Reminder Reports Template Display ;11/03/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ; Called from PXRMXT/PXRMXTF
 …
  .I $E(PXRMLCSC,2)'="A" W ! D ARRS
  I DONE Q
- W !?PSTART,"Print Locations without Patients:",?32,$S($G(PXRMPML)=0:"NO",1:"YES")
  S IC="" F  S IC=$O(PXRMRCAT(IC)) Q:IC=""  D  Q:DONE
  .W !,?PSTART W:IC=1 "Category:"
 …
  ;form feed to new page
  ;---------------------
 PAGE I ($E(IOST,1,2)="C-")&(IO=IO(0))&(PAGE>0) D
+PAGE I ($E(IOST)="C")&(IO=IO(0))&(PAGE>0) D
  .S DIR(0)="E"
  .W !

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTE.m

-              r628
+              r636
 PXRMXTE ; SLC/PJH - Reminder Reports Template Edit ;11/27/2006
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXTE ; SLC/PJH - Reminder Reports Template Edit ;08/03/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ; Called from PXRMYD,PXRMXD
 …
  ;Report type (detail or summary)
  S DR=DR_";1.4"
- ;Print Locations without patients
- S DR=DR_";1.7"
  ;Reminder Categories
  I $D(^PXRMPT(810.1,DA,12,0))>0 D

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTF.m

r628	r636
1	1	PXRMXTF ; SLC/PJH - Reminder Reports Template Filing ;05/02/2002
2		;;2.0;CLINICAL REMINDERS;6;Feb 04, 2005;Build 123
	2	;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3	3	;
4	4	; Called from PXRMXTA

FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTU.m

-              r628
+              r636
 PXRMXTU ; SLC/PJH - Reminder Reports Template Update ;11/27/2006
  ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXTU ; SLC/PJH - Reminder Reports Template Update ;11/03/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
  ; Called from PXRMYD,PXRMXD (also at UPD from PXRMXPR/PXRMYPR)
 …
+ ;
  ;Save single fields into FDA
  F IC="NAME","PXRMLCSC","PXRMPRIM","PXRMREP","PXRMSEL","PXRMTYP","PXRMPML" D
+ F IC="NAME","PXRMLCSC","PXRMPRIM","PXRMREP","PXRMSEL","PXRMTYP" D
  .S FDA(810.1,MODE,XREF(IC))=$G(@IC)
  F IC="PXRMFD","PXRMSCAT","RUN","TITLE" D

Context Navigation

Legend:

Download in other formats: