Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXTU.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXTU.m
r613 r623 1 PXRMXTU ; SLC/PJH - Reminder Reports Template Update ;11/27/20062 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 3 4 5 6 7 8 START 9 10 EXIT 11 12 13 14 SAVE 15 SAV1 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 FILE(INP,UPD,CLR) 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 F IC="NAME","PXRMLCSC","PXRMPRIM","PXRMREP","PXRMSEL","PXRMTYP","PXRMPML" D62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 SUB1(OUTPUT,VAR,PIECE) 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 SUB2(FLD,VAR) 136 137 138 139 140 141 142 143 ASK(YESNO) 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 HELP(CALL) 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 COPY 185 186 187 188 189 190 191 192 193 194 195 196 UPD 197 198 199 200 201 NAME 202 203 204 205 206 207 208 209 INP 210 211 212 213 214 215 216 1 PXRMXTU ; SLC/PJH - Reminder Reports Template Update ;11/03/2005 2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 3 ; 4 ; Called from PXRMYD,PXRMXD (also at UPD from PXRMXPR/PXRMYPR) 5 ; 6 ;Option to create a new template 7 ;------------------------------- 8 START N PXRMASK,MSG D ASK(.PXRMASK) 9 I $G(PXRMASK)="Y" D SAVE 10 EXIT Q 11 ; 12 ;Ask name for new template 13 ;------------------------- 14 SAVE N X,Y,DIC,DLAYGO 15 SAV1 S DIC=810.1,DLAYGO=DIC,DIC(0)="QAELX" 16 S DIC("A")="STORE REPORT LOGIC IN TEMPLATE NAME: " 17 W ! 18 D ^DIC 19 I X="" W !,"A template name must be entered" G SAV1 20 I X=(U_U) S DTOUT=1 21 I Y=-1 S DUOUT=1 W !,"Details not saved" Q 22 I $D(DTOUT)!$D(DUOUT) Q 23 ;Check 24 I ($P(Y,U,3)'=1) W !,"This template name already exists" G SAV1 25 ;Get template name and title 26 S PXRMTMP=Y,TITLE=$P($G(^PXRMPT(810.1,$P(Y,U),0)),U,2) 27 S $P(PXRMTMP,U,3)=TITLE 28 ;File details 29 D FILE(Y,1,0) 30 ;File not saved message 31 I $D(MSG) D Q 32 .N DA,DIK 33 .S DA=$P(Y,U),DIK="^PXRMPT(810.1," D ^DIK 34 .D MESS^PXRMXTF(4,$P(PXRMTMP,U,2)) 35 ;File saved message 36 D MESS^PXRMXTF(1,$P(PXRMTMP,U,2)) 37 Q 38 ; 39 ;File template detail 40 ;-------------------- 41 FILE(INP,UPD,CLR) ; 42 N CNT,FDA,FDAIEN,FNO,IC,INT,MODE,NAME,X 43 S FDAIEN(1)=$P(INP,U),NAME=$P(INP,U,2) 44 ;Save exit flags - needed for rollback 45 N DUOUT,DTOUT 46 ; 47 ;Update or Add 48 S MODE=$S(UPD:(FDAIEN(1)_","),1:"+1,") 49 ;Delete entries from existing template 50 I CLR D 51 .N DA S DA=0 52 .F S DA=$O(^PXRMPT(810.1,FDAIEN(1),DA)) Q:'DA D 53 ..K ^PXRMPT(810.1,FDAIEN(1),DA) 54 ; 55 I PXRMSEL="L" S X=PXRMLCSC,PXRMLCSC=$P(PXRMLCSC,U) 56 ; 57 N MREF,XREF 58 D XREF^PXRMXTB 59 ; 60 ;Save single fields into FDA 61 F IC="NAME","PXRMLCSC","PXRMPRIM","PXRMREP","PXRMSEL","PXRMTYP" D 62 .S FDA(810.1,MODE,XREF(IC))=$G(@IC) 63 F IC="PXRMFD","PXRMSCAT","RUN","TITLE" D 64 .S FDA(810.1,MODE,XREF(IC))=$G(@IC) 65 ; 66 I PXRMSEL="L" S PXRMLCSC=X 67 ; 68 ;Save Arrays into FDA 69 ; 70 ;Reminder Items 71 S CNT=1 72 D SUB1(.PXRMREM,"810.12",1) 73 ;Save Facility codes 74 D SUB1(.PXRMFAC,"810.13",1) 75 ;Save Provider codes 76 D SUB1(.PXRMPRV,"810.14",1) 77 ;Save Patient codes 78 D SUB1(.PXRMPAT,"810.16",1) 79 ;Save OE/RR Team codes 80 D SUB1(.PXRMOTM,"810.17",1) 81 ;Save PCMM Team codes 82 D SUB1(.PXRMPCM,"810.18",1) 83 ;Save Hospital Location codes 84 D SUB1(.PXRMLCHL,"810.11",2) 85 ;Save Clinic Stop codes 86 D SUB1(.PXRMCS,"810.111",2) 87 ;Save Clinic groups 88 D SUB1(.PXRMCGRP,"810.112",1) 89 ;Save Reminder Categories 90 D SUB1(.PXRMRCAT,"810.113",1) 91 ;Save Patient lists 92 D SUB1(.PXRMLIST,"810.114",1) 93 ; 94 ;Update template file 95 D UPDATE^DIE("S","FDA","FDAIEN","MSG") 96 ; 97 I $D(MSG) D 98 .W !!,"Update failed, UPDATE^DIE returned the following error message:" 99 .S IC="MSG" 100 .F S IC=$Q(@IC) Q:IC="" W !,IC,"=",@IC 101 .W !,"Examine the above error message for the reason.",! 102 .H 2 103 Q 104 ; 105 ;Save arrays into FDA 106 ;-------------------- 107 SUB1(OUTPUT,VAR,PIECE) ; 108 S IC="" 109 ;This is use for saving individual reminders back to the original 110 ;template 111 I VAR=810.12,$D(PXRMTREM($P(INP,U)))>0 D Q 112 .F S IC=$O(PXRMTREM($P(INP,U),IC)) Q:IC="" D 113 ..S INT=$P(PXRMTREM($P(INP,U),IC),U,PIECE),CNT=CNT+1 114 ..S FDA(VAR,"+"_CNT_","_MODE,.01)=INT 115 ..S FDA(VAR,"+"_CNT_","_MODE,.02)=IC 116 ; 117 ;This is use for saving individual reminders category back to the 118 ;original template 119 I VAR=810.113,$D(PXRMTCAT($P(INP,U)))>0 D Q 120 .F S IC=$O(PXRMTCAT($P(INP,U),IC)) Q:IC="" D 121 ..S INT=$P(PXRMTCAT($P(INP,U),IC),U,PIECE),CNT=CNT+1 122 ..S FDA(VAR,"+"_CNT_","_MODE,.01)=INT 123 ..S FDA(VAR,"+"_CNT_","_MODE,.02)=IC 124 ; 125 ;this is use for saving everything else to the template 126 F S IC=$O(OUTPUT(IC)) Q:IC="" D 127 .S INT=$P(OUTPUT(IC),U,PIECE),CNT=CNT+1 128 .S FDA(VAR,"+"_CNT_","_MODE,.01)=INT 129 .;Save Display order for reminders and categories 130 .I (VAR=810.12)!(VAR=810.113) S FDA(VAR,"+"_CNT_","_MODE,.02)=IC 131 Q 132 ; 133 ;Save Service Categories into FDA 134 ;-------------------------------- 135 SUB2(FLD,VAR) ; 136 F IC=1:1 S INT=$E(@FLD,IC) Q:INT="" D 137 .S CNT=CNT+1,FDA(VAR,"+"_CNT_","_MODE,.01)=INT 138 Q 139 ; 140 ; 141 ;Option to save a new template 142 ;----------------------------- 143 ASK(YESNO) ; 144 N X,Y,TEXT 145 K DIROUT,DIRUT,DTOUT,DUOUT 146 S DIR(0)="YA0" 147 S DIR("A")="Create a new report template: " 148 S DIR("B")="N" 149 S DIR("?")="Enter Y or N. For detailed help type ??" 150 S DIR("??")=U_"D HELP^PXRMXTU(1)" 151 W ! 152 D ^DIR K DIR 153 I $D(DIROUT) S DTOUT=1 154 I $D(DTOUT)!($D(DUOUT)) Q 155 S YESNO=$E(Y(0)) 156 Q 157 ; 158 ;General help text routine. Write out the text in the HTEXT array 159 ;---------------------------------------------------------------- 160 HELP(CALL) ; 161 N HTEXT 162 N DIWF,DIWL,DIWR,IC 163 S DIWF="C70",DIWL=0,DIWR=70 164 ; 165 I CALL=1 D 166 .S HTEXT(1)="Enter 'Y' to save the reporting parameters as a report" 167 .S HTEXT(2)="template from which the report may be re-run in future." 168 ; 169 K ^UTILITY($J,"W") 170 S IC="" 171 F S IC=$O(HTEXT(IC)) Q:IC="" D 172 . S X=HTEXT(IC) 173 . D ^DIWP 174 W ! 175 S IC=0 176 F S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC="" D 177 . W !,^UTILITY($J,"W",0,IC,0) 178 K ^UTILITY($J,"W") 179 W ! 180 Q 181 ; 182 ;Save template info to new name 183 ;------------------------------ 184 COPY N PXRMLCSC,PXRMPRIM,PRRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS 185 N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS 186 ;Load arrays from original template PXRMTMP 187 D LOAD^PXRMXT I $D(MSG) Q 188 ;Clear last run date 189 S RUN="" 190 ;Save arrays to new ID 191 D FILE(NEWTEMP,0) 192 Q 193 ; 194 ;Update print template last run date (called from PXRMYPR/PXRMXPR) 195 ;----------------------------------------------------------------- 196 UPD S ^PXRMPT(810.1,$P(PXRMTMP,U),7)=PXRMXST 197 Q 198 ; 199 ;Called as an input transform for 810.1/NAME 200 ;------------------------------------------- 201 NAME Q:'$D(X) Q:X="" Q:$G(PXRMTYP)="" 202 ;Disallow duplicate template names 203 Q:'$D(^PXRMPT(810.1,"B",X)) 204 W !,"This template name already exists" K X 205 Q 206 ; 207 ;Called as an input transform for 810.1/PXRMFD 208 ;--------------------------------------------- 209 INP Q:'$D(X) Q:X="" 210 ;If inpatient wards prompt only for Admissions/Current Patients 211 I $G(PXRMINP),"FP"[X D 212 .W !,"Select either Inpatient Admissions or Current Inpatients" K X 213 ;If other locations prompt only for Prior visits/Future Appts 214 I '$G(PXRMINP),"AC"[X D 215 .W !,"Select either Future Appointments or Prior Visits" K X 216 Q
Note:
See TracChangeset
for help on using the changeset viewer.
