Changeset 636 for FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMRUL1.m
- Timestamp:
- Dec 4, 2009, 8:26:01 PM (14 years ago)
- Location:
- FOIAVistA/tag/r
- Files:
-
- 1 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMRUL1.m
r628 r636 1 PXRMRUL1 ; SLC/AGP,PKR - Patient list routines. ; 0 3/29/20072 ;;2.0;CLINICAL REMINDERS;**4 ,6**;Feb 04, 2005;Build 1231 PXRMRUL1 ; SLC/AGP,PKR - Patient list routines. ; 08/11/2006 2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 3 3 ; 4 ;5 ASK(PLIEN,OPT) ;Verify patient list name6 N X,Y,TEXT7 K DIROUT,DIRUT,DTOUT,DUOUT8 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 DIR14 I $D(DIROUT) S DTOUT=115 I $D(DTOUT)!($D(DUOUT)) Q16 I $E(Y(0))="N" S DUOUT=1 Q17 Q18 ;19 COPY(IENO) ;Copy patient list20 ;Check if OK to copy21 D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)22 N FDA,IENN,IND,MSG,NNAME,ODATA,OEPIEN,ONAME,ORULE,PATCREAT,TEXT,X,Y23 ;Select list to copy to24 S TEXT="Select PATIENT LIST name to copy to: "25 D PLIST^PXRMLCR(.IENN,TEXT,IENO) Q:$D(DUOUT)!$D(DTOUT) Q:'IENN26 S NNAME=$P($G(^PXRMXP(810.5,IENN,0)),U)27 ;28 ;Get original Patient List record29 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 info35 S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")36 S IND=IENN_","37 S FDA(810.5,IND,.01)=NNAME38 S FDA(810.5,IND,.04)=$$NOW^XLFDT39 S FDA(810.5,IND,.05)=OEPIEN40 S FDA(810.5,IND,.06)=ORULE41 S FDA(810.5,IND,.07)=$G(DUZ)42 S FDA(810.5,IND,.08)=TYPE43 D UPDATE^DIE("","FDA","","MSG")44 ;Error45 I $D(MSG) D ERR46 ;47 W !!,"Completed copy of '"_ONAME_"'"48 W !,"into '"_NNAME_"'",! H 249 K ^TMP($J,"PXRMRULE")50 Q51 ;52 CRLST(NAME,CLASS) ;Create new patient list53 N IEN54 ;Check if name exists55 S IEN=$O(^PXRMXP(810.5,"B",NAME,"")) I IEN Q IEN56 ;Otherwise create national entry57 N FDA,FDAIEN,MSG58 S FDA(810.5,"+1,",.01)=NAME59 S FDA(810.5,"+1,",100)=CLASS60 S FDA(810.5,"+1,",.07)=$G(DUZ)61 ;Make stub public62 S FDA(810.5,"+1,",.08)="PUB"63 D UPDATE^DIE("","FDA","FDAIEN","MSG")64 ;Error65 I $D(MSG) Q 066 ;Otherwise list ien67 Q FDAIEN(1)68 ;69 COUNT(NODE) ;Count the number of entries.70 N DFN,NUM71 S (DFN,NUM)=072 F S DFN=$O(^TMP($J,NODE,DFN)) Q:DFN="" S NUM=NUM+173 Q NUM74 ;75 DELETE(LIST) ;Delete Patient list76 I '$$VEDIT^PXRMUTIL("^PXRMXP(810.5,",LIST) D Q77 .W !!,?5,"VA- and national class patient lists may not be deleted" H 278 .S DUOUT=179 ;Check if this is the right list80 D ASK(LIST,"Delete") Q:$D(DUOUT)!$D(DTOUT)81 ;82 N DA,DIK,DUOUT83 ;Lock patient list84 D LOCK Q:$D(DUOUT)85 ;Kill List86 S DA=LIST,DIK="^PXRMXP(810.5,"87 D ^DIK88 ;Unlock patient list89 D UNLOCK90 Q91 ;92 4 DATECHK(DATE) ; 93 5 I DATE=0 Q 1 94 6 S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T") 95 7 Q $$VDT^PXRMINTR(DATE) 96 ;97 DATES(LBBDT,LBEDT,RBDT,REDT,FARR) ;Set the dates in the finding array to98 ;FileMan dates.99 N FI,PXRMDATE,TBDT,TEDT100 S FI=0101 F S FI=+$O(FARR(20,FI)) Q:FI=0 D102 . S TBDT=$P(FARR(20,FI,0),U,8),TEDT=$P(FARR(20,FI,0),U,11)103 . I TBDT="",TEDT="" D104 .. S $P(FARR(20,FI,0),U,8)=RBDT,$P(FARR(20,FI,0),U,11)=REDT105 . E D106 .. 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)=TEDT112 Q113 ;114 ERR ;Error Handler115 N ERROR,IC,REF116 S ERROR(1)="Unable to build patient list : "117 S ERROR(2)=NAME118 S ERROR(3)="Error in UPDATE^DIE, needs further investigation"119 ; Move MSG into Error120 S REF="MSG"121 F IC=4:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF122 ;Screen message123 D EN^DDIOL(.ERROR)124 Q125 8 ; 126 9 INSERT(FROUT,DFN,TNAME,TFIEV,RSTOP) ;Save patient data. … … 153 36 Q INST 154 37 ; 155 LOCK L +^PXRMXP(810.5,LIST):0156 E W !!?5,"Another user is using this patient list" S DUOUT=1157 Q158 ;159 38 LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical 160 39 ;operator LOGOP to generate a new list and return it in LIST1 … … 178 57 Q 179 58 ; 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) 59 REM(FRACT,RIEN,RSTART,RSTOP,PNODE) ;Process reminder finding rule 60 D BLDPLST^PXRMPLST(RIEN,PNODE,1,RSTOP) 186 61 ;Remove, Select or Add Findings operations 187 62 I FRACT="A" D LOGOP(FROUT,PNODE,"!") Q … … 190 65 Q 191 66 ; 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 67 TERM(FRACT,FRTIEN,RSTART,RSTOP,PNODE,INST) ;Process TERM finding rule 68 N FINDPA,FINDING,FNAME,PLIST,PXRMDATE,PXRMDEBG,TERMARR,TFIEV,TNAME 196 69 ;Get term definition array 197 70 D TERM^PXRMLDR(FRTIEN,.TERMARR) 198 71 S TNAME=$P(TERMARR(0),U,1) 199 72 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) 73 ;Set start and end dates 202 74 S $P(FINDPA(0),U,8)=RSTART,$P(FINDPA(0),U,11)=RSTOP,PXRMDATE=RSTOP 203 75 ; … … 205 77 I FRACT="A" D Q 206 78 .;Process term for date range 207 .D EVALPL^PXRMTER L(.FINDPA,.TERMARR,PNODE)79 .D EVALPL^PXRMTERM(.FINDPA,.TERMARR,PNODE) 208 80 .;Merge lists if operation is add 209 81 .M ^TMP($J,FROUT)=^TMP($J,PNODE,1) … … 226 98 Q 227 99 ; 228 UNLOCK L -^PXRMXP(810.5,LIST) Q229 ;
Note:
See TracChangeset
for help on using the changeset viewer.