[628] | 1 | PXRMRUL1 ; SLC/AGP,PKR - Patient list routines. ; 03/29/2007
|
---|
| 2 | ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
---|
| 3 | ;
|
---|
| 4 | ;
|
---|
| 5 | ASK(PLIEN,OPT) ;Verify patient list name
|
---|
| 6 | N X,Y,TEXT
|
---|
| 7 | K DIROUT,DIRUT,DTOUT,DUOUT
|
---|
| 8 | S DIR(0)="YA0"
|
---|
| 9 | S DIR("A")=OPT_" patient list "_$P($G(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
|
---|
| 10 | S DIR("B")="N"
|
---|
| 11 | S DIR("?")="Enter Y or N. For detailed help type ??"
|
---|
| 12 | W !
|
---|
| 13 | D ^DIR K DIR
|
---|
| 14 | I $D(DIROUT) S DTOUT=1
|
---|
| 15 | I $D(DTOUT)!($D(DUOUT)) Q
|
---|
| 16 | I $E(Y(0))="N" S DUOUT=1 Q
|
---|
| 17 | Q
|
---|
| 18 | ;
|
---|
| 19 | COPY(IENO) ;Copy patient list
|
---|
| 20 | ;Check if OK to copy
|
---|
| 21 | D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)
|
---|
| 22 | N FDA,IENN,IND,MSG,NNAME,ODATA,OEPIEN,ONAME,ORULE,PATCREAT,TEXT,X,Y
|
---|
| 23 | ;Select list to copy to
|
---|
| 24 | S TEXT="Select PATIENT LIST name to copy to: "
|
---|
| 25 | D PLIST^PXRMLCR(.IENN,TEXT,IENO) Q:$D(DUOUT)!$D(DTOUT) Q:'IENN
|
---|
| 26 | S NNAME=$P($G(^PXRMXP(810.5,IENN,0)),U)
|
---|
| 27 | ;
|
---|
| 28 | ;Get original Patient List record
|
---|
| 29 | S ODATA=$G(^PXRMXP(810.5,IENO,0))
|
---|
| 30 | S ONAME=$P(ODATA,U),OEPIEN=$P(ODATA,U,5),ORULE=$P(ODATA,U,6)
|
---|
| 31 | ;
|
---|
| 32 | M ^PXRMXP(810.5,IENN)=^PXRMXP(810.5,IENO)
|
---|
| 33 | D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2)
|
---|
| 34 | ;Update header info
|
---|
| 35 | S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
|
---|
| 36 | S IND=IENN_","
|
---|
| 37 | S FDA(810.5,IND,.01)=NNAME
|
---|
| 38 | S FDA(810.5,IND,.04)=$$NOW^XLFDT
|
---|
| 39 | S FDA(810.5,IND,.05)=OEPIEN
|
---|
| 40 | S FDA(810.5,IND,.06)=ORULE
|
---|
| 41 | S FDA(810.5,IND,.07)=$G(DUZ)
|
---|
| 42 | S FDA(810.5,IND,.08)=TYPE
|
---|
| 43 | D UPDATE^DIE("","FDA","","MSG")
|
---|
| 44 | ;Error
|
---|
| 45 | I $D(MSG) D ERR
|
---|
| 46 | ;
|
---|
| 47 | W !!,"Completed copy of '"_ONAME_"'"
|
---|
| 48 | W !,"into '"_NNAME_"'",! H 2
|
---|
| 49 | K ^TMP($J,"PXRMRULE")
|
---|
| 50 | Q
|
---|
| 51 | ;
|
---|
| 52 | CRLST(NAME,CLASS) ;Create new patient list
|
---|
| 53 | N IEN
|
---|
| 54 | ;Check if name exists
|
---|
| 55 | S IEN=$O(^PXRMXP(810.5,"B",NAME,"")) I IEN Q IEN
|
---|
| 56 | ;Otherwise create national entry
|
---|
| 57 | N FDA,FDAIEN,MSG
|
---|
| 58 | S FDA(810.5,"+1,",.01)=NAME
|
---|
| 59 | S FDA(810.5,"+1,",100)=CLASS
|
---|
| 60 | S FDA(810.5,"+1,",.07)=$G(DUZ)
|
---|
| 61 | ;Make stub public
|
---|
| 62 | S FDA(810.5,"+1,",.08)="PUB"
|
---|
| 63 | D UPDATE^DIE("","FDA","FDAIEN","MSG")
|
---|
| 64 | ;Error
|
---|
| 65 | I $D(MSG) Q 0
|
---|
| 66 | ;Otherwise list ien
|
---|
| 67 | Q FDAIEN(1)
|
---|
| 68 | ;
|
---|
| 69 | COUNT(NODE) ;Count the number of entries.
|
---|
| 70 | N DFN,NUM
|
---|
| 71 | S (DFN,NUM)=0
|
---|
| 72 | F S DFN=$O(^TMP($J,NODE,DFN)) Q:DFN="" S NUM=NUM+1
|
---|
| 73 | Q NUM
|
---|
| 74 | ;
|
---|
| 75 | DELETE(LIST) ;Delete Patient list
|
---|
| 76 | I '$$VEDIT^PXRMUTIL("^PXRMXP(810.5,",LIST) D Q
|
---|
| 77 | .W !!,?5,"VA- and national class patient lists may not be deleted" H 2
|
---|
| 78 | .S DUOUT=1
|
---|
| 79 | ;Check if this is the right list
|
---|
| 80 | D ASK(LIST,"Delete") Q:$D(DUOUT)!$D(DTOUT)
|
---|
| 81 | ;
|
---|
| 82 | N DA,DIK,DUOUT
|
---|
| 83 | ;Lock patient list
|
---|
| 84 | D LOCK Q:$D(DUOUT)
|
---|
| 85 | ;Kill List
|
---|
| 86 | S DA=LIST,DIK="^PXRMXP(810.5,"
|
---|
| 87 | D ^DIK
|
---|
| 88 | ;Unlock patient list
|
---|
| 89 | D UNLOCK
|
---|
| 90 | Q
|
---|
| 91 | ;
|
---|
| 92 | DATECHK(DATE) ;
|
---|
| 93 | I DATE=0 Q 1
|
---|
| 94 | S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
|
---|
| 95 | Q $$VDT^PXRMINTR(DATE)
|
---|
| 96 | ;
|
---|
| 97 | DATES(LBBDT,LBEDT,RBDT,REDT,FARR) ;Set the dates in the finding array to
|
---|
| 98 | ;FileMan dates.
|
---|
| 99 | N FI,PXRMDATE,TBDT,TEDT
|
---|
| 100 | S FI=0
|
---|
| 101 | F S FI=+$O(FARR(20,FI)) Q:FI=0 D
|
---|
| 102 | . S TBDT=$P(FARR(20,FI,0),U,8),TEDT=$P(FARR(20,FI,0),U,11)
|
---|
| 103 | . I TBDT="",TEDT="" D
|
---|
| 104 | .. S $P(FARR(20,FI,0),U,8)=RBDT,$P(FARR(20,FI,0),U,11)=REDT
|
---|
| 105 | . E D
|
---|
| 106 | .. S PXRMDATE=$S(TBDT["BDT":LBBDT,1:LBEDT)
|
---|
| 107 | .. S TBDT=$S(TBDT="":0,TBDT=0:0,TBDT="BDT":LBBDT,1:$$CTFMD^PXRMDATE(TBDT))
|
---|
| 108 | .. S PXRMDATE=$S(TEDT["BDT":LBBDT,1:LBEDT)
|
---|
| 109 | .. S TEDT=$S(TEDT="":"T",TEDT=0:"T",TEDT="BDT":LBBDT,1:TEDT)
|
---|
| 110 | .. S TEDT=$$CTFMD^PXRMDATE(TEDT)
|
---|
| 111 | .. S $P(FARR(20,FI,0),U,8)=TBDT,$P(FARR(20,FI,0),U,11)=TEDT
|
---|
| 112 | Q
|
---|
| 113 | ;
|
---|
| 114 | ERR ;Error Handler
|
---|
| 115 | N ERROR,IC,REF
|
---|
| 116 | S ERROR(1)="Unable to build patient list : "
|
---|
| 117 | S ERROR(2)=NAME
|
---|
| 118 | S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
|
---|
| 119 | ; Move MSG into Error
|
---|
| 120 | S REF="MSG"
|
---|
| 121 | F IC=4:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF
|
---|
| 122 | ;Screen message
|
---|
| 123 | D EN^DDIOL(.ERROR)
|
---|
| 124 | Q
|
---|
| 125 | ;
|
---|
| 126 | INSERT(FROUT,DFN,TNAME,TFIEV,RSTOP) ;Save patient data.
|
---|
| 127 | I TFIEV(1)=0 Q
|
---|
| 128 | N DATA,DONE,IND,LEN,REF,ROOT,START,SUB,TEMP
|
---|
| 129 | S REF="TFIEV(1,""CSUB"")"
|
---|
| 130 | S PROOT=$P(REF,")",1)
|
---|
| 131 | ;Build the root so we can tell when we are done.
|
---|
| 132 | S TEMP=$NA(@REF)
|
---|
| 133 | S ROOT=$P(TEMP,")",1)
|
---|
| 134 | S REF=$Q(@REF)
|
---|
| 135 | I REF'[ROOT Q
|
---|
| 136 | S DONE=0
|
---|
| 137 | F Q:(REF="")!(DONE) D
|
---|
| 138 | . S START=$F(REF,ROOT)
|
---|
| 139 | . S LEN=$L(REF)-1
|
---|
| 140 | . S IND=$E(REF,START,LEN)
|
---|
| 141 | . S DATA(TNAME_IND)=@REF
|
---|
| 142 | . S REF=$Q(@REF)
|
---|
| 143 | . I REF'[ROOT S DONE=1
|
---|
| 144 | I $D(DATA) M ^TMP($J,FROUT,DFN,"DATA")=DATA
|
---|
| 145 | Q
|
---|
| 146 | ;
|
---|
| 147 | INST(DFN) ;Get the PCMM Institution.
|
---|
| 148 | N DATE,INST
|
---|
| 149 | ;Check PCMM
|
---|
| 150 | S DATE=$S($G(PXRMDATE)'="":$P(PXRMDATE,"."),1:DT)
|
---|
| 151 | ;DBIA #1916
|
---|
| 152 | S INST=$P($$INSTPCTM^SCAPMC(DFN,DATE),U,3,4)
|
---|
| 153 | Q INST
|
---|
| 154 | ;
|
---|
| 155 | LOCK L +^PXRMXP(810.5,LIST):0
|
---|
| 156 | E W !!?5,"Another user is using this patient list" S DUOUT=1
|
---|
| 157 | Q
|
---|
| 158 | ;
|
---|
| 159 | LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical
|
---|
| 160 | ;operator LOGOP to generate a new list and return it in LIST1
|
---|
| 161 | N DFN1,DFN2
|
---|
| 162 | I LOGOP="&" D Q
|
---|
| 163 | . S DFN1=""
|
---|
| 164 | . F S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1="" D
|
---|
| 165 | .. I $D(^TMP($J,LIST2,DFN1)) M ^TMP($J,LIST1,DFN1)=^TMP($J,LIST2,DFN1) Q
|
---|
| 166 | .. K ^TMP($J,LIST1,DFN1)
|
---|
| 167 | ;
|
---|
| 168 | ;"~" represents "&'".
|
---|
| 169 | I LOGOP="~" D Q
|
---|
| 170 | . S DFN1=""
|
---|
| 171 | . F S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1="" D
|
---|
| 172 | .. I $D(^TMP($J,LIST2,DFN1)) K ^TMP($J,LIST1,DFN1)
|
---|
| 173 | ;
|
---|
| 174 | I LOGOP="!" D
|
---|
| 175 | . S DFN2=""
|
---|
| 176 | . F S DFN2=$O(^TMP($J,LIST2,DFN2)) Q:DFN2="" D
|
---|
| 177 | .. M ^TMP($J,LIST1,DFN2)=^TMP($J,LIST2,DFN2)
|
---|
| 178 | Q
|
---|
| 179 | ;
|
---|
| 180 | REM(FRACT,RIEN,LBBDT,LBEDT,RSTART,RSTOP,PNODE) ;Process reminder finding rule
|
---|
| 181 | N DEFFARR,PXRMDATE
|
---|
| 182 | D DEF^PXRMLDR(RIEN,.DEFARR)
|
---|
| 183 | D DATES(LBBDT,LBEDT,RSTART,RSTOP,.DEFARR)
|
---|
| 184 | S PXRMDATE=RSTOP
|
---|
| 185 | D BLDPLST^PXRMPLST(.DEFARR,PNODE,1)
|
---|
| 186 | ;Remove, Select or Add Findings operations
|
---|
| 187 | I FRACT="A" D LOGOP(FROUT,PNODE,"!") Q
|
---|
| 188 | I FRACT="D" D LOGOP(FROUT,PNODE,"~") Q
|
---|
| 189 | I FRACT="S" D LOGOP(FROUT,PNODE,"&") Q
|
---|
| 190 | Q
|
---|
| 191 | ;
|
---|
| 192 | TERM(FRACT,FRTIEN,LBBDT,LBEDT,RSTART,RSTOP,PNODE,INST) ;Process TERM finding
|
---|
| 193 | ;rules
|
---|
| 194 | N FINDPA,FINDING,FNAME,PLIST,PXRMDATE,PXRMDEBG
|
---|
| 195 | N TERMARR,TFIEV,TNAME
|
---|
| 196 | ;Get term definition array
|
---|
| 197 | D TERM^PXRMLDR(FRTIEN,.TERMARR)
|
---|
| 198 | S TNAME=$P(TERMARR(0),U,1)
|
---|
| 199 | S INST=$S(FRACT'="F":0,TNAME="VA-PCMM INSTITUTION":1,TNAME="VA-IHD STATION CODE":1,1:0)
|
---|
| 200 | ;Set begin and end dates in the term.
|
---|
| 201 | D DATES(LBBDT,LBEDT,RSTART,RSTOP,.TERMARR)
|
---|
| 202 | S $P(FINDPA(0),U,8)=RSTART,$P(FINDPA(0),U,11)=RSTOP,PXRMDATE=RSTOP
|
---|
| 203 | ;
|
---|
| 204 | ;Add operation
|
---|
| 205 | I FRACT="A" D Q
|
---|
| 206 | .;Process term for date range
|
---|
| 207 | .D EVALPL^PXRMTERL(.FINDPA,.TERMARR,PNODE)
|
---|
| 208 | .;Merge lists if operation is add
|
---|
| 209 | .M ^TMP($J,FROUT)=^TMP($J,PNODE,1)
|
---|
| 210 | ;Remove, Select or Insert Findings operations
|
---|
| 211 | I FRACT="F" S PXRMDEBG=1
|
---|
| 212 | S DFN=0
|
---|
| 213 | F S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN D
|
---|
| 214 | .I INST S ^TMP($J,FROUT,DFN,"INST")=$$INST(DFN) Q
|
---|
| 215 | .;Evaluate term
|
---|
| 216 | .K TFIEV D IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.TFIEV)
|
---|
| 217 | .;Delete any ^TMP patient in PLIST if action is remove
|
---|
| 218 | .I FRACT="R",TFIEV(1) K ^TMP($J,FROUT,DFN) Q
|
---|
| 219 | .;Delete any ^TMP patient not in PLIST if action is select
|
---|
| 220 | .I FRACT="S",'TFIEV(1) K ^TMP($J,FROUT,DFN) Q
|
---|
| 221 | .I FRACT="F",TFIEV(1) D
|
---|
| 222 | .. S FINDING=TFIEV(1,"FINDING")
|
---|
| 223 | .. I '$D(FNAME(FINDING)) S FNAME(FINDING)=$$GETFNAME^PXRMDATA(FINDING)
|
---|
| 224 | .. S TFIEV(1,"CSUB","FINDING NAME")=FNAME(FINDING)
|
---|
| 225 | .. D INSERT(FROUT,DFN,TNAME,.TFIEV,RSTOP)
|
---|
| 226 | Q
|
---|
| 227 | ;
|
---|
| 228 | UNLOCK L -^PXRMXP(810.5,LIST) Q
|
---|
| 229 | ;
|
---|