Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMSTA1.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/PXRMSTA1.m
r613 r623 1 PXRMSTA1 ; SLC/AGP - Routines for building status list. ;09/06/20072 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 3 4 5 6 7 8 CLEAR(GBL,FILE,DA) 9 10 11 12 13 14 15 16 STATUS(DA,FILE) 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 ADDDEL(ANS,GBL,FILE,TYPE,NODE,WILD,DA,UPDATE,DELALL) 37 I $G(ANS)="" S ANS=$$PROMPT("S^A:ADD STATUS;D:DELETE A STATUS;S:SAVE AND QUIT;Q:QUIT WITHOUT SAVING CHANGES")38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 ADD(GBL,FILE,CSTATUS,TYPE,WILD,DA,UPDATE) 53 54 55 56 57 58 59 60 61 62 63 64 .I $G(TAXTYPE)="R"!($G(TAXTYPE)="B")D DATA^PXRMSTA2(FILE,.DA,"RAMIS(71,","",.STATUS)65 66 .;I $G(TAXTYPE)="B" D DATA^PXRMSTA2(FILE,.DA,"TAX","",.STATUS)67 68 69 70 71 72 73 ADDEX 74 75 76 77 78 79 80 81 82 DEFAULT(GBL,TYPE,NODE,RFILE,DELETE,DA) 83 84 85 86 87 88 89 90 91 92 93 .I $G(TAXTYPE)="R"!($G(TAXTYPE)="B")S FILE=7094 .;I $G(TAXTYPE)="P" S FILE=900001195 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 DELETE(GBL,FILE,CSTATUS,NODE,WILD,DA,UPDATE,DELALL) 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 DISPLAY(GBL,UPDATE,WILD,DELALL) 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 UPDATE(FILE,UPDATE,CSTATUS,DA,DELALL) 161 162 163 164 165 166 167 168 169 170 171 172 EXIT 173 174 175 PROMPT(STR );176 177 S HTEXT(1)="Select 'A' to add a status to the current status list.\\Select 'D' to"178 S HTEXT(2)="delete a status from the list.\\Select 'S' to save your changes and quit. "179 S HTEXT(3)="\\Select 'Q' to quit without saving your changes."180 181 182 183 184 185 186 187 188 ASK(STR,HTEXT) 189 190 191 192 193 194 195 196 197 198 199 200 TAXTYPE(TERMIEN,HELP) 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 TAXNODE(TAXIEN,HELP) 218 219 220 221 222 223 224 225 226 227 228 229 230 TERMSTAT(TIEN) 231 232 233 234 235 236 237 WARN 238 239 240 241 242 243 244 245 246 247 248 249 250 251 1 PXRMSTA1 ; SLC/AGP - Routines for building status list. ;06/20/2006 2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 3 ; 4 ;This routine and PXRMSTA2 will allow users to select the 5 ;approriate status for Orders, Medication, Taxonomy, Problem List, 6 ;and Radiology Procedure findings items. 7 ; 8 CLEAR(GBL,FILE,DA) ; 9 N IEN,NODE,DIK,TEMP 10 I FILE="D" S DIK="^PXD(811.9,"_DA(2)_",20,"_DA(1)_",5," 11 I FILE="T" S DIK="^PXRMD(811.5,"_DA(2)_",20,"_DA(1)_",5," 12 S DA=0 F S DA=$O(@GBL@(DA(2),20,DA(1),5,DA)) Q:DA'>0 S TEMP(DA)="" 13 S DA=0 F S DA=$O(TEMP(DA)) Q:DA'>0 D ^DIK 14 Q 15 ; 16 STATUS(DA,FILE) ; 17 N ANS,DELSTS,DELALL,GBL,NODE,PXRMRX,STATUS,STS,TAXIEN,TERMIEN,TAXTYPE,TTYPE,TYPE 18 N RXTYPE,TAXNODE,TERMTYPE,Y 19 N CSTATUS,UPDATE,HTEXT,OSTAUS,WILD 20 S DA(2)=DA(1),DA(1)=DA,DA="",UPDATE=0,DELALL=0 21 I FILE="D" S GBL="^PXD(811.9)" 22 I FILE="T" S GBL="^PXRMD(811.5)" 23 S NODE=$G(@GBL@(DA(2),20,DA(1),0)) 24 S TYPE=$P($G(@GBL@(DA(2),20,DA(1),0)),U) 25 S WILD=0 26 ;check for current defined statuses if none set the default values 27 I FILE="D",$P($G(@GBL@(DA(2),20,DA(1),5,0)),U,4)'>0 D DEFAULT(GBL,TYPE,NODE,FILE,0,.DA) 28 ;I FILE="T",$P($G(@GBL@(DA(2),20,DA(1),5,0)),U,4)>0 D 29 ;.S STS="" F S STS=$O(@GBL@(DA(2),20,DA(1),5,"B",STS)) Q:STS="" S DELSTS(STS)="" 30 ;display the current status 31 D DISPLAY(GBL,UPDATE,.WILD,DELALL) 32 ;do inital prompt 33 D ADDDEL($G(ANS),GBL,FILE,TYPE,NODE,WILD,.DA,.UPDATE,.DELALL) 34 Q 35 ; 36 ADDDEL(ANS,GBL,FILE,TYPE,NODE,WILD,DA,UPDATE,DELALL) ; 37 I $G(ANS)="" S ANS=$$PROMPT("S^A:ADD STATUS;D:DELETE A STATUS;S:SAVE AND QUIT;Q:QUIT WITHOUT SAVING CHANGES","S") 38 I "ADDASQ"'[ANS Q 39 I ANS="A",WILD=1 D 40 .W !,"Wildcard is already on the status list all possible statuses will be evaluated." 41 .W !,"To add a specific status please remove the wildcard first." 42 .S UPDATE=0 H 1 43 I ANS="A",WILD=0 D ADD(GBL,FILE,.CSTATUS,TYPE,.WILD,.DA,.UPDATE) 44 I ANS="D" D DELETE(GBL,FILE,.CSTATUS,NODE,.WILD,.DA,.UPDATE,.DELALL) 45 I ANS="S" S UPDATE="S" 46 I ANS="Q" S UPDATE="Q" 47 I UPDATE'="S",UPDATE'="Q" S DELALL=0 D ADDDEL("",GBL,FILE,TYPE,NODE,.WILD,.DA,.UPDATE,.DELALL) 48 ; only update the new record if the action is Save 49 I UPDATE="S" D UPDATE(FILE,.UPDATE,.CSTATUS,.DA,.DELALL) 50 Q 51 ; 52 ADD(GBL,FILE,CSTATUS,TYPE,WILD,DA,UPDATE) ; 53 N ANS,STATUS,TERMIEN 54 ;Find what types of finding is in the term 55 I TYPE["PXRMD(811.5," D 56 .S TERMIEN=$P($G(TYPE),";") 57 .S TYPE=$$TERMSTAT(TERMIEN) I TYPE=0 Q 58 .I TYPE["PXD" S TAXTYPE=$$TAXTYPE(TERMIEN,"") 59 I TYPE=0 Q 60 ;find out what is in the taxonomy 61 I TYPE["PXD(811.2,",$G(TAXTYPE)="" S TAXTYPE=$$TAXNODE($P(TYPE,";"),"") 62 I TYPE[";" S TYPE=$P($G(TYPE),";",2) 63 I TYPE="PXD(811.2," D G ADDEX 64 .I $G(TAXTYPE)="R" D DATA^PXRMSTA2(FILE,.DA,"RAMIS(71,","",.STATUS) 65 .;I $G(TAXTYPE)="P" D DATA^PXRMSTA2(FILE,.DA,"PROB","",.STATUS) 66 .I $G(TAXTYPE)="B" D DATA^PXRMSTA2(FILE,.DA,"TAX","",.STATUS) 67 ; handle drug finding items 68 I TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D G ADDEX 69 .D SRXTYL^PXRMRXTY(NODE,.RXTYPE) 70 .D DATA^PXRMSTA2(FILE,.DA,"DRUG",.RXTYPE,.STATUS) 71 ;radiology and orderable item finding item 72 D DATA^PXRMSTA2(FILE,.DA,TYPE,"",.STATUS) 73 ADDEX ; 74 I '$D(STATUS) S UPDATE=0 Q 75 S STAT="" F S STAT=$O(STATUS(STAT)) Q:STAT=""!(WILD)=1 D 76 .I STAT["*" S WILD=1 Q 77 .S CSTATUS(STAT)="" 78 I WILD=1 K CSTATUS S CSTATUS("*")="" 79 S UPDATE=1 D DISPLAY(GBL,UPDATE,.WILD,0) 80 Q 81 ; 82 DEFAULT(GBL,TYPE,NODE,RFILE,DELETE,DA) ; 83 N ANS,FDA,FILE,IND,MSG,STATUS,TERMIEN 84 S FILE="" 85 I TYPE["PXRMD(811.5," D 86 .S TERMIEN=$P($G(TYPE),";") 87 .S TYPE=$$TERMSTAT(TERMIEN) I TYPE=0 S STATUS="" Q 88 .I TYPE["PXD" S TAXTYPE=$$TAXTYPE(TERMIEN,"") 89 I TYPE=0 Q 90 I TYPE["PXD(811.2,",$G(TAXTYPE)="" S TAXTYPE=$$TAXNODE($P(TYPE,";"),"") 91 I TYPE[";" S TYPE=$P($G(TYPE),";",2) 92 I TYPE="PXD(811.2," D 93 .I $G(TAXTYPE)="R" S FILE=70 94 .I $G(TAXTYPE)="P" S FILE=9000011 95 I FILE="",TYPE="ORD(101.43," S FILE=100 96 I FILE="",TYPE="RAMIS(71," S FILE=70 97 I FILE="",TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D 98 .N DSTATUS,NAME,STATUSI,STATUSN,STATUSO,RXTYPE 99 .D SRXTYL^PXRMRXTY(NODE,.RXTYPE) 100 .I $D(RXTYPE("O")) D DEFAULT^PXRMSTAT(52,.STATUSO) D 101 ..F IND=1:1:STATUSO(0) S DSTATUS(STATUSO(IND))="" 102 .I $D(RXTYPE("I")) D DEFAULT^PXRMSTAT(55,.STATUSI) D 103 ..F IND=1:1:STATUSI(0) S DSTATUS(STATUSI(IND))="" 104 .I $D(RXTYPE("N")) D DEFAULT^PXRMSTAT("55NVA",.STATUSN) D 105 ..F IND=1:1:STATUSN(0) S DSTATUS(STATUSN(IND))="" 106 .S NAME="",IND=0 F S NAME=$O(DSTATUS(NAME)) Q:NAME="" D 107 ..S IND=IND+1 S STATUS(IND)=NAME 108 .S STATUS(0)=IND 109 I '$D(STATUS) D DEFAULT^PXRMSTAT(FILE,.STATUS) 110 F IND=1:1:STATUS(0) Q:$D(MSG)>0 D 111 .I DELETE=1 S CSTATUS(STATUS(IND))="" Q 112 .I $D(@GBL@(DA(2),20,DA(1),5,"B",STATUS(IND))) Q 113 .I RFILE="D" S FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND) 114 .I RFILE="T" S FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND) 115 .D UPDATE^DIE("","FDA","","MSG") 116 I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2 117 Q 118 ; 119 DELETE(GBL,FILE,CSTATUS,NODE,WILD,DA,UPDATE,DELALL) ; 120 N ANS,CNT,DIK,NUM,NAME,DIR,TMP,TMPARR,Y 121 S CNT=0,NAME="" F S NAME=$O(CSTATUS(NAME)) Q:NAME="" D 122 .S CNT=CNT+1 S TMPARR(CNT)=CNT_" - "_NAME,TMP(CNT)=NAME 123 S DIR(0)="LO^1:"_CNT_"" 124 M DIR("A")=TMPARR 125 S DIR("A")="Select which status to be deleted" 126 ;S DIR("?")=HELP 127 D ^DIR 128 I $D(DTOUT)!($D(DUOUT))!($G(Y)="") Q 129 S CNT=0 F X=1:1:$L(Y(0)) D 130 .I $E(Y(0),X)="," S CNT=CNT+1,NUM=$P(Y(0),",",CNT) S NAME=TMP(NUM) K CSTATUS(NAME) I NAME["*" S WILD=0 131 S UPDATE=1 132 I FILE="T",$D(CSTATUS)'>0 S DELALL=1 133 ;.S DIK="^PXRMD(811.5,"_DA(2)_",20,"_DA(1)_",5," 134 ;D CLEAR(GBL,FILE,.DA) 135 ;I $D(CSTATUS)'>0 S DA=0 F S DA=$O(^PXRMD(811.5,DA(2),20,DA(1),5,DA)) Q:DA'>0 D ^DIK 136 ;I '$D(CSTATUS) D CLEAR(GBL,FILE,.DA) D DEFAULT(GBL,TYPE,NODE,FILE,1,.DA) 137 ;I '$D(CSTATUS),FILE="D" D DEFAULT(GBL,TYPE,NODE,FILE,1,.DA) 138 D DISPLAY(GBL,UPDATE,.WILD,DELALL) 139 Q 140 ; 141 DISPLAY(GBL,UPDATE,WILD,DELALL) ; 142 ;display statuses defined in the 5 node or display statuses if CStatus 143 ;array has been loaded 144 N NAME 145 S NAME="" 146 I ((UPDATE=1)&(DELALL=1))!(($D(CSTATUS)'>0)&(UPDATE=0)&(GBL["811.5")&('$D(@GBL@(DA(2),20,DA(1),5)))) W !!,"No statuses defined for this finding item" W ! Q 147 W !!,"Statuses already defined for this finding item:" 148 ;I $D(CSTATUS)'>0,UPDATE=1 D 149 ;.F S NAME=$O(@GBL@(DA(2),20,DA(1),5,"B",NAME)) Q:NAME="" D 150 ;..S CSTATUS(NAME)=$O(^PXD(811.9,DA(2),20,DA(1),5,"B","NAME","")) 151 I $D(CSTATUS)'>0,UPDATE=0 D 152 .F S NAME=$O(@GBL@(DA(2),20,DA(1),5,"B",NAME)) Q:NAME="" D 153 ..I NAME["*" S WILD=1 154 ..W !,NAME S CSTATUS(NAME)=$O(^PXD(811.9,DA(2),20,DA(1),5,"B","NAME","")) 155 I UPDATE=1 F S NAME=$O(CSTATUS(NAME)) Q:NAME="" W !,NAME I NAME["*" S WILD=1 156 W ! 157 Q 158 ; 159 ; 160 UPDATE(FILE,UPDATE,CSTATUS,DA,DELALL) ; 161 N FDA,MSG,NAME 162 I UPDATE="S" S UPDATE=1 163 I UPDATE=0,$D(CSTATUS) G EXIT 164 D CLEAR(GBL,FILE,.DA) 165 I $D(CSTATUS)'>0 S UPDATE=0,DELALL=0 G EXIT 166 I $D(CSTATUS)'>0 S UPDATE=1,DELALL=1 G EXIT 167 S NAME="" F S NAME=$O(CSTATUS(NAME)) Q:NAME=""!($D(MSG)>0) D 168 .I FILE="D" S FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME 169 .I FILE="T" S FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME 170 .D UPDATE^DIE("","FDA","","MSG") 171 I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2 172 EXIT ; 173 Q 174 ; 175 PROMPT(STR,DEFAULT) ; 176 N DIR,HTEXT 177 S HTEXT(1)="Select 'A' to add a status to the current status list. Select 'D' to " 178 S HTEXT(2)="delete a status from the list. Select 'S' to save your changes and quit. " 179 S HTEXT(3)="Select 'Q' to quit without saving your changes." 180 S DIR(0)=STR 181 S DIR("B")="S" 182 S DIR("?")="Select one of the above option or '^' to quit. Enter ?? for detail help." 183 S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)" 184 D ^DIR 185 I $G(Y)="" S Y=U 186 Q Y 187 ; 188 ASK(STR,HTEXT) ; 189 N DIR,HTEXT 190 I '$D(HTEXT) D 191 .S HTEXT(1)="Enter 'Y' to continue editing the Status List or '^' to Quit" 192 S DIR(0)="YA0" 193 S DIR("A")=STR 194 S DIR("B")="N" 195 S DIR("?")="Select either 'Y' or 'N' or '^' to quit. Enter ?? for detail help." 196 S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)" 197 D ^DIR 198 Q Y 199 ; 200 TAXTYPE(TERMIEN,HELP) ; 201 ;use to determine the Rx type of the term and the type of taxonomy 202 N ARRAY,BOTH,CNT,IEN,TAXNODE,RAD,PL,RESULT,TYPE 203 S (BOTH,PL,RAD,RESULT)=0 204 S IEN=0 F S IEN=$O(^PXRMD(811.5,TERMIEN,20,IEN)) Q:+IEN'>0 D 205 .S TAXNODE=$G(^PXRMD(811.5,TERMIEN,20,IEN,0)) 206 .S ARRAY($P($P($G(TAXNODE),U),";"))="" 207 I $D(ARRAY)>0 S IEN=0 F S IEN=$O(ARRAY(IEN)) Q:IEN'>0 D 208 .S TYPE=$$TAXNODE(IEN,$G(HELP)) 209 .I TYPE="R" S RAD=1 210 .I TYPE="P" S PL=1 211 .I TYPE="B" S BOTH=1 212 I RAD=1,PL=1 S RESULT="B" Q 213 I RAD=1,PL=0,BOTH=0 S RESULT="R" 214 I RAD=0,PL=1,BOTH=0 S RESULT="P" 215 Q RESULT 216 ; 217 TAXNODE(TAXIEN,HELP) ; 218 ;use to determine the type of taxonomy 219 N TAXNODE,ICD,CPT,ARRAY,RAD,PL,BOTH,RADM,PLM,RESULT 220 S (BOTH,PL,PLM,RAD,RADM,RESULT)=0 221 D CHECK^PXRMBXTL(TAXIEN,"") 222 I $D(^PXD(811.3,TAXIEN,71,"RCPTP"))>0 S RAD=1 223 I $D(^PXD(811.3,TAXIEN,"PDS",9000011))>0 S PL=1 224 I RAD=1,PL=1 S RESULT="B" 225 I RAD=1,PL=0 S RESULT="R" 226 I RAD=0,PL=1 S RESULT="P" 227 Q RESULT 228 ; 229 ; 230 TERMSTAT(TIEN) ; 231 N CNT,FIEN,NODE 232 S (CNT,FIEN)=0 233 S TYPE=0 F S FIEN=$O(^PXRMD(811.5,TIEN,20,FIEN)) Q:+FIEN=0!(CNT=1) D 234 . S NODE=$G(^PXRMD(811.5,TIEN,20,FIEN,0)),TYPE=$P(NODE,U),CNT=CNT+1 235 Q TYPE 236 ; 237 WARN ; 238 ;If the whole entry is being deleted don't give the warning. 239 I $G(PXRMDEFD) Q 240 I $G(PXRMTMD) Q 241 ;Do not execute as part of exchange. 242 I $G(PXRMEXCH) Q 243 N TEXT 244 S TEXT(1)="" 245 S TEXT(2)="Since you changed the value of Rx Type, you should review the status list" 246 S TEXT(3)="for the finding to make sure it is still appropriate." 247 S TEXT(4)="" 248 D EN^DDIOL(.TEXT) 249 Q 250 ; 251 ;
Note:
See TracChangeset
for help on using the changeset viewer.
